HCoop / bpt / guile.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | blame (incremental) | history | HEAD
Merge branch 'master' into boehm-demers-weiser-gc
[bpt/guile.git] / libguile / goops.c
CommitLineData
5305df84 1/* Copyright (C) 1998,1999,2000,2001,2002,2003,2004,2008
366ecaec 2 * Free Software Foundation, Inc.
6d77c894 3 *
73be1d9e
MV		 4 * This library is free software; you can redistribute it and/or
5 * modify it under the terms of the GNU Lesser General Public
6 * License as published by the Free Software Foundation; either
7 * version 2.1 of the License, or (at your option) any later version.
6d77c894 8 *
73be1d9e 9 * This library is distributed in the hope that it will be useful,
80662eda 10 * but WITHOUT ANY WARRANTY; without even the implied warranty of
73be1d9e
MV		 11 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
12 * Lesser General Public License for more details.
6d77c894 13 *
73be1d9e
MV		 14 * You should have received a copy of the GNU Lesser General Public
15 * License along with this library; if not, write to the Free Software
92205699 16 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
73be1d9e 17 */
80662eda
MD		 18\f
19
20/* This software is a derivative work of other copyrighted softwares; the
21 * copyright notices of these softwares are placed in the file COPYRIGHTS
22 *
23 * This file is based upon stklos.c from the STk distribution by
24 * Erick Gallesio <eg@unice.fr>.
25 */
26
dbb605f5
LC		 27#ifdef HAVE_CONFIG_H
28# include <config.h>
29#endif
30
80662eda 31#include <stdio.h>
51ef99f7 32#include <assert.h>
80662eda
MD		 33
34#include "libguile/_scm.h"
35#include "libguile/alist.h"
4e047c3e 36#include "libguile/async.h"
539d5410 37#include "libguile/chars.h"
80662eda
MD		 38#include "libguile/debug.h"
39#include "libguile/dynl.h"
40#include "libguile/dynwind.h"
41#include "libguile/eval.h"
42#include "libguile/hashtab.h"
43#include "libguile/keywords.h"
44#include "libguile/macros.h"
45#include "libguile/modules.h"
46#include "libguile/objects.h"
47#include "libguile/ports.h"
48#include "libguile/procprop.h"
49#include "libguile/random.h"
fdc28395 50#include "libguile/root.h"
80662eda
MD		 51#include "libguile/smob.h"
52#include "libguile/strings.h"
53#include "libguile/strports.h"
54#include "libguile/vectors.h"
55#include "libguile/weaks.h"
56
ca83b028 57#include "libguile/validate.h"
80662eda
MD		 58#include "libguile/goops.h"
59
80662eda
MD		 60#define SPEC_OF(x) SCM_SLOT (x, scm_si_specializers)
61
34d19ef6 62#define DEFVAR(v, val) \
1afff620
KN		 63{ scm_eval (scm_list_3 (scm_sym_define_public, (v), (val)), \
64 scm_module_goops); }
80662eda
MD		 65/* Temporary hack until we get the new module system */
66/*fixme* Should optimize by keeping track of the variable object itself */
fdc28395
KN		 67#define GETVAR(v) (SCM_VARIABLE_REF (scm_call_2 (scm_goops_lookup_closure, \
68 (v), SCM_BOOL_F)))
80662eda
MD		 69
70/* Fixme: Should use already interned symbols */
cc95e00a
MV		 71
72#define CALL_GF1(name, a) (scm_call_1 (GETVAR (scm_from_locale_symbol (name)), \
1afff620 73 a))
cc95e00a 74#define CALL_GF2(name, a, b) (scm_call_2 (GETVAR (scm_from_locale_symbol (name)), \
1afff620 75 a, b))
cc95e00a 76#define CALL_GF3(name, a, b, c) (scm_call_3 (GETVAR (scm_from_locale_symbol (name)), \
1afff620 77 a, b, c))
cc95e00a 78#define CALL_GF4(name, a, b, c, d) (scm_call_4 (GETVAR (scm_from_locale_symbol (name)), \
1afff620 79 a, b, c, d))
80662eda
MD		 80
81/* Class redefinition protocol:
82
83 A class is represented by a heap header h1 which points to a
84 malloc:ed memory block m1.
85
86 When a new version of a class is created, a new header h2 and
87 memory block m2 are allocated. The headers h1 and h2 then switch
88 pointers so that h1 refers to m2 and h2 to m1. In this way, names
89 bound to h1 will point to the new class at the same time as h2 will
7346de61 90 be a handle which the GC will use to free m1.
80662eda
MD		 91
92 The `redefined' slot of m1 will be set to point to h1. An old
7346de61 93 instance will have its class pointer (the CAR of the heap header)
80662eda
MD		 94 pointing to m1. The non-immediate `redefined'-slot in m1 indicates
95 the class modification and the new class pointer can be found via
96 h1.
97*/
98
80662eda
MD		 99/* The following definition is located in libguile/objects.h:
100#define SCM_OBJ_CLASS_REDEF(x) (SCM_STRUCT_VTABLE_DATA(x)[scm_si_redefined])
101*/
102
0fd7dcd3
MD		 103#define TEST_CHANGE_CLASS(obj, class) \
104 { \
105 class = SCM_CLASS_OF (obj); \
7888309b 106 if (scm_is_true (SCM_OBJ_CLASS_REDEF (obj))) \
0fd7dcd3
MD		 107 { \
108 scm_change_object_class (obj, class, SCM_OBJ_CLASS_REDEF (obj));\
109 class = SCM_CLASS_OF (obj); \
110 } \
80662eda
MD		 111 }
112
113#define NXT_MTHD_METHODS(m) (SCM_VELTS (m)[1])
114#define NXT_MTHD_ARGS(m) (SCM_VELTS (m)[2])
115
116#define SCM_GOOPS_UNBOUND SCM_UNBOUND
117#define SCM_GOOPS_UNBOUNDP(x) ((x) == SCM_GOOPS_UNBOUND)
118
119static int goops_loaded_p = 0;
92c2555f 120static scm_t_rstate *goops_rstate;
80662eda
MD		 121
122static SCM scm_goops_lookup_closure;
123
539d5410
MV		 124/* These variables are filled in by the object system when loaded. */
125SCM scm_class_boolean, scm_class_char, scm_class_pair;
126SCM scm_class_procedure, scm_class_string, scm_class_symbol;
127SCM scm_class_procedure_with_setter, scm_class_primitive_generic;
128SCM scm_class_vector, scm_class_null;
129SCM scm_class_integer, scm_class_real, scm_class_complex, scm_class_fraction;
130SCM scm_class_unknown;
80662eda 131SCM scm_class_top, scm_class_object, scm_class_class;
74b6d6e4 132SCM scm_class_applicable;
80662eda 133SCM scm_class_entity, scm_class_entity_with_setter;
bbf8d523 134SCM scm_class_generic, scm_class_generic_with_setter;
f8af5c6d 135SCM scm_class_accessor;
bbf8d523 136SCM scm_class_extended_generic, scm_class_extended_generic_with_setter;
74b6d6e4 137SCM scm_class_extended_accessor;
bbf8d523 138SCM scm_class_method;
f8af5c6d 139SCM scm_class_simple_method, scm_class_accessor_method;
80662eda
MD		 140SCM scm_class_procedure_class;
141SCM scm_class_operator_class, scm_class_operator_with_setter_class;
142SCM scm_class_entity_class;
143SCM scm_class_number, scm_class_list;
144SCM scm_class_keyword;
145SCM scm_class_port, scm_class_input_output_port;
146SCM scm_class_input_port, scm_class_output_port;
147SCM scm_class_foreign_class, scm_class_foreign_object;
148SCM scm_class_foreign_slot;
149SCM scm_class_self, scm_class_protected;
150SCM scm_class_opaque, scm_class_read_only;
151SCM scm_class_protected_opaque, scm_class_protected_read_only;
152SCM scm_class_scm;
153SCM scm_class_int, scm_class_float, scm_class_double;
154
539d5410
MV		 155SCM *scm_port_class = 0;
156SCM *scm_smob_class = 0;
157
158SCM scm_no_applicable_method;
159
80662eda
MD		 160SCM_SYMBOL (scm_sym_define_public, "define-public");
161
162static SCM scm_make_unbound (void);
163static SCM scm_unbound_p (SCM obj);
398d8ee1
KN		 164static SCM scm_assert_bound (SCM value, SCM obj);
165static SCM scm_at_assert_bound_ref (SCM obj, SCM index);
166static SCM scm_sys_goops_loaded (void);
80662eda 167
539d5410
MV		 168/* This function is used for efficient type dispatch. */
169SCM_DEFINE (scm_class_of, "class-of", 1, 0, 0,
170 (SCM x),
171 "Return the class of @var{x}.")
172#define FUNC_NAME s_scm_class_of
173{
174 switch (SCM_ITAG3 (x))
175 {
176 case scm_tc3_int_1:
177 case scm_tc3_int_2:
178 return scm_class_integer;
179
180 case scm_tc3_imm24:
181 if (SCM_CHARP (x))
182 return scm_class_char;
183 else if (scm_is_bool (x))
184 return scm_class_boolean;
185 else if (scm_is_null (x))
186 return scm_class_null;
187 else
188 return scm_class_unknown;
189
190 case scm_tc3_cons:
191 switch (SCM_TYP7 (x))
192 {
193 case scm_tcs_cons_nimcar:
194 return scm_class_pair;
195 case scm_tcs_closures:
196 return scm_class_procedure;
197 case scm_tc7_symbol:
198 return scm_class_symbol;
199 case scm_tc7_vector:
200 case scm_tc7_wvect:
201 return scm_class_vector;
202 case scm_tc7_string:
203 return scm_class_string;
204 case scm_tc7_number:
205 switch SCM_TYP16 (x) {
206 case scm_tc16_big:
207 return scm_class_integer;
208 case scm_tc16_real:
209 return scm_class_real;
210 case scm_tc16_complex:
211 return scm_class_complex;
212 case scm_tc16_fraction:
213 return scm_class_fraction;
214 }
215 case scm_tc7_asubr:
216 case scm_tc7_subr_0:
217 case scm_tc7_subr_1:
218 case scm_tc7_dsubr:
219 case scm_tc7_cxr:
220 case scm_tc7_subr_3:
221 case scm_tc7_subr_2:
222 case scm_tc7_rpsubr:
223 case scm_tc7_subr_1o:
224 case scm_tc7_subr_2o:
225 case scm_tc7_lsubr_2:
226 case scm_tc7_lsubr:
227 if (SCM_SUBR_GENERIC (x) && *SCM_SUBR_GENERIC (x))
228 return scm_class_primitive_generic;
229 else
230 return scm_class_procedure;
231 case scm_tc7_cclo:
232 return scm_class_procedure;
233 case scm_tc7_pws:
234 return scm_class_procedure_with_setter;
235
236 case scm_tc7_smob:
237 {
238 scm_t_bits type = SCM_TYP16 (x);
239 if (type != scm_tc16_port_with_ps)
240 return scm_smob_class[SCM_TC2SMOBNUM (type)];
241 x = SCM_PORT_WITH_PS_PORT (x);
242 /* fall through to ports */
243 }
244 case scm_tc7_port:
245 return scm_port_class[(SCM_WRTNG & SCM_CELL_WORD_0 (x)
246 ? (SCM_RDNG & SCM_CELL_WORD_0 (x)
247 ? SCM_INOUT_PCLASS_INDEX | SCM_PTOBNUM (x)
248 : SCM_OUT_PCLASS_INDEX | SCM_PTOBNUM (x))
249 : SCM_IN_PCLASS_INDEX | SCM_PTOBNUM (x))];
250 case scm_tcs_struct:
251 if (SCM_OBJ_CLASS_FLAGS (x) & SCM_CLASSF_GOOPS_VALID)
252 return SCM_CLASS_OF (x);
253 else if (SCM_OBJ_CLASS_FLAGS (x) & SCM_CLASSF_GOOPS)
254 {
255 /* Goops object */
256 if (! scm_is_false (SCM_OBJ_CLASS_REDEF (x)))
257 scm_change_object_class (x,
258 SCM_CLASS_OF (x), /* old */
259 SCM_OBJ_CLASS_REDEF (x)); /* new */
260 return SCM_CLASS_OF (x);
261 }
262 else
263 {
264 /* ordinary struct */
265 SCM handle = scm_struct_create_handle (SCM_STRUCT_VTABLE (x));
266 if (scm_is_true (SCM_STRUCT_TABLE_CLASS (SCM_CDR (handle))))
267 return SCM_STRUCT_TABLE_CLASS (SCM_CDR (handle));
268 else
269 {
270 SCM name = SCM_STRUCT_TABLE_NAME (SCM_CDR (handle));
271 SCM class = scm_make_extended_class (scm_is_true (name)
272 ? scm_i_symbol_chars (name)
273 : 0,
274 SCM_I_OPERATORP (x));
275 SCM_SET_STRUCT_TABLE_CLASS (SCM_CDR (handle), class);
276 return class;
277 }
278 }
279 default:
280 if (scm_is_pair (x))
281 return scm_class_pair;
282 else
283 return scm_class_unknown;
284 }
285
286 case scm_tc3_struct:
287 case scm_tc3_tc7_1:
288 case scm_tc3_tc7_2:
289 case scm_tc3_closure:
290 /* Never reached */
291 break;
292 }
293 return scm_class_unknown;
294}
295#undef FUNC_NAME
296
80662eda
MD		 297/******************************************************************************
298 *
299 * Compute-cpl
300 *
bbf8d523
MD		 301 * This version doesn't fully handle multiple-inheritance. It serves
302 * only for booting classes and will be overloaded in Scheme
80662eda
MD		 303 *
304 ******************************************************************************/
305
80662eda
MD		 306static SCM
307map (SCM (*proc) (SCM), SCM ls)
308{
d2e53ed6 309 if (scm_is_null (ls))
80662eda 310 return ls;
6b80d352
DH		 311 else
312 {
313 SCM res = scm_cons (proc (SCM_CAR (ls)), SCM_EOL);
314 SCM h = res;
315 ls = SCM_CDR (ls);
d2e53ed6 316 while (!scm_is_null (ls))
6b80d352
DH		 317 {
318 SCM_SETCDR (h, scm_cons (proc (SCM_CAR (ls)), SCM_EOL));
319 h = SCM_CDR (h);
320 ls = SCM_CDR (ls);
321 }
322 return res;
323 }
80662eda
MD		 324}
325
326static SCM
327filter_cpl (SCM ls)
328{
329 SCM res = SCM_EOL;
d2e53ed6 330 while (!scm_is_null (ls))
80662eda
MD		 331 {
332 SCM el = SCM_CAR (ls);
7888309b 333 if (scm_is_false (scm_c_memq (el, res)))
80662eda
MD		 334 res = scm_cons (el, res);
335 ls = SCM_CDR (ls);
336 }
337 return res;
338}
339
340static SCM
341compute_cpl (SCM class)
342{
343 if (goops_loaded_p)
344 return CALL_GF1 ("compute-cpl", class);
345 else
346 {
347 SCM supers = SCM_SLOT (class, scm_si_direct_supers);
348 SCM ls = scm_append (scm_acons (class, supers,
349 map (compute_cpl, supers)));
350 return scm_reverse_x (filter_cpl (ls), SCM_EOL);
351 }
352}
353
354/******************************************************************************
355 *
356 * compute-slots
357 *
358 ******************************************************************************/
359
360static SCM
361remove_duplicate_slots (SCM l, SCM res, SCM slots_already_seen)
362{
363 SCM tmp;
364
d2e53ed6 365 if (scm_is_null (l))
80662eda
MD		 366 return res;
367
368 tmp = SCM_CAAR (l);
cc95e00a 369 if (!scm_is_symbol (tmp))
1afff620 370 scm_misc_error ("%compute-slots", "bad slot name ~S", scm_list_1 (tmp));
6d77c894 371
7888309b 372 if (scm_is_false (scm_c_memq (tmp, slots_already_seen))) {
80662eda
MD		 373 res = scm_cons (SCM_CAR (l), res);
374 slots_already_seen = scm_cons (tmp, slots_already_seen);
375 }
6d77c894 376
80662eda
MD		 377 return remove_duplicate_slots (SCM_CDR (l), res, slots_already_seen);
378}
379
380static SCM
381build_slots_list (SCM dslots, SCM cpl)
382{
383 register SCM res = dslots;
384
d2e53ed6 385 for (cpl = SCM_CDR (cpl); !scm_is_null (cpl); cpl = SCM_CDR (cpl))
1afff620
KN		 386 res = scm_append (scm_list_2 (SCM_SLOT (SCM_CAR (cpl),
387 scm_si_direct_slots),
388 res));
80662eda
MD		 389
390 /* res contains a list of slots. Remove slots which appears more than once */
391 return remove_duplicate_slots (scm_reverse (res), SCM_EOL, SCM_EOL);
392}
393
394static SCM
395maplist (SCM ls)
396{
397 SCM orig = ls;
d2e53ed6 398 while (!scm_is_null (ls))
80662eda 399 {
d2e53ed6 400 if (!scm_is_pair (SCM_CAR (ls)))
80662eda
MD		 401 SCM_SETCAR (ls, scm_cons (SCM_CAR (ls), SCM_EOL));
402 ls = SCM_CDR (ls);
403 }
404 return orig;
405}
406
80662eda 407
23437298
DH		 408SCM_DEFINE (scm_sys_compute_slots, "%compute-slots", 1, 0, 0,
409 (SCM class),
5352393c
MG		 410 "Return a list consisting of the names of all slots belonging to\n"
411 "class @var{class}, i. e. the slots of @var{class} and of all of\n"
6d77c894 412 "its superclasses.")
23437298 413#define FUNC_NAME s_scm_sys_compute_slots
80662eda 414{
398d8ee1 415 SCM_VALIDATE_CLASS (1, class);
80662eda
MD		 416 return build_slots_list (SCM_SLOT (class, scm_si_direct_slots),
417 SCM_SLOT (class, scm_si_cpl));
418}
23437298
DH		 419#undef FUNC_NAME
420
80662eda
MD		 421
422/******************************************************************************
423 *
424 * compute-getters-n-setters
6d77c894
TTN		 425 *
426 * This version doesn't handle slot options. It serves only for booting
dcb410ec 427 * classes and will be overloaded in Scheme.
80662eda
MD		 428 *
429 ******************************************************************************/
430
431SCM_KEYWORD (k_init_value, "init-value");
432SCM_KEYWORD (k_init_thunk, "init-thunk");
433
434static SCM
435compute_getters_n_setters (SCM slots)
436{
437 SCM res = SCM_EOL;
438 SCM *cdrloc = &res;
c014a02e 439 long i = 0;
80662eda 440
d2e53ed6 441 for ( ; !scm_is_null (slots); slots = SCM_CDR (slots))
80662eda
MD		 442 {
443 SCM init = SCM_BOOL_F;
444 SCM options = SCM_CDAR (slots);
d2e53ed6 445 if (!scm_is_null (options))
80662eda
MD		 446 {
447 init = scm_get_keyword (k_init_value, options, 0);
448 if (init)
366ecaec
DH		 449 {
450 init = scm_i_eval_x (scm_list_3 (scm_sym_lambda,
451 SCM_EOL,
452 scm_list_2 (scm_sym_quote,
453 init)),
454 SCM_EOL);
455 }
80662eda
MD		 456 else
457 init = scm_get_keyword (k_init_thunk, options, SCM_BOOL_F);
458 }
459 *cdrloc = scm_cons (scm_cons (SCM_CAAR (slots),
460 scm_cons (init,
e11e83f3 461 scm_from_int (i++))),
80662eda
MD		 462 SCM_EOL);
463 cdrloc = SCM_CDRLOC (*cdrloc);
464 }
465 return res;
466}
467
468/******************************************************************************
469 *
470 * initialize-object
471 *
472 ******************************************************************************/
473
474/*fixme* Manufacture keywords in advance */
475SCM
c014a02e 476scm_i_get_keyword (SCM key, SCM l, long len, SCM default_value, const char *subr)
80662eda 477{
c014a02e 478 long i;
23437298
DH		 479
480 for (i = 0; i != len; i += 2)
80662eda 481 {
23437298
DH		 482 SCM obj = SCM_CAR (l);
483
c598539a 484 if (!scm_is_keyword (obj))
1afff620 485 scm_misc_error (subr, "bad keyword: ~S", scm_list_1 (obj));
bc36d050 486 else if (scm_is_eq (obj, key))
80662eda 487 return SCM_CADR (l);
23437298
DH		 488 else
489 l = SCM_CDDR (l);
80662eda 490 }
23437298 491
80662eda
MD		 492 return default_value;
493}
494
80662eda 495
23437298
DH		 496SCM_DEFINE (scm_get_keyword, "get-keyword", 3, 0, 0,
497 (SCM key, SCM l, SCM default_value),
5352393c
MG		 498 "Determine an associated value for the keyword @var{key} from\n"
499 "the list @var{l}. The list @var{l} has to consist of an even\n"
500 "number of elements, where, starting with the first, every\n"
501 "second element is a keyword, followed by its associated value.\n"
502 "If @var{l} does not hold a value for @var{key}, the value\n"
503 "@var{default_value} is returned.")
23437298 504#define FUNC_NAME s_scm_get_keyword
80662eda 505{
c014a02e 506 long len;
23437298 507
c598539a 508 SCM_ASSERT (scm_is_keyword (key), key, SCM_ARG1, FUNC_NAME);
80662eda 509 len = scm_ilength (l);
b6311c08 510 if (len < 0 || len % 2 == 1)
1afff620 511 scm_misc_error (FUNC_NAME, "Bad keyword-value list: ~S", scm_list_1 (l));
23437298
DH		 512
513 return scm_i_get_keyword (key, l, len, default_value, FUNC_NAME);
80662eda 514}
23437298
DH		 515#undef FUNC_NAME
516
80662eda 517
80662eda
MD		 518SCM_KEYWORD (k_init_keyword, "init-keyword");
519
520static SCM get_slot_value (SCM class, SCM obj, SCM slotdef);
521static SCM set_slot_value (SCM class, SCM obj, SCM slotdef, SCM value);
522
398d8ee1
KN		 523SCM_DEFINE (scm_sys_initialize_object, "%initialize-object", 2, 0, 0,
524 (SCM obj, SCM initargs),
6bcefd15
MG		 525 "Initialize the object @var{obj} with the given arguments\n"
526 "@var{initargs}.")
398d8ee1 527#define FUNC_NAME s_scm_sys_initialize_object
80662eda
MD		 528{
529 SCM tmp, get_n_set, slots;
530 SCM class = SCM_CLASS_OF (obj);
c014a02e 531 long n_initargs;
80662eda 532
398d8ee1 533 SCM_VALIDATE_INSTANCE (1, obj);
80662eda 534 n_initargs = scm_ilength (initargs);
398d8ee1 535 SCM_ASSERT ((n_initargs & 1) == 0, initargs, SCM_ARG2, FUNC_NAME);
6d77c894 536
80662eda
MD		 537 get_n_set = SCM_SLOT (class, scm_si_getters_n_setters);
538 slots = SCM_SLOT (class, scm_si_slots);
6d77c894 539
80662eda
MD		 540 /* See for each slot how it must be initialized */
541 for (;
d2e53ed6 542 !scm_is_null (slots);
80662eda
MD		 543 get_n_set = SCM_CDR (get_n_set), slots = SCM_CDR (slots))
544 {
545 SCM slot_name = SCM_CAR (slots);
546 SCM slot_value = 0;
6d77c894 547
d2e53ed6 548 if (!scm_is_null (SCM_CDR (slot_name)))
80662eda
MD		 549 {
550 /* This slot admits (perhaps) to be initialized at creation time */
c014a02e 551 long n = scm_ilength (SCM_CDR (slot_name));
80662eda 552 if (n & 1) /* odd or -1 */
398d8ee1 553 SCM_MISC_ERROR ("class contains bogus slot definition: ~S",
1afff620 554 scm_list_1 (slot_name));
80662eda
MD		 555 tmp = scm_i_get_keyword (k_init_keyword,
556 SCM_CDR (slot_name),
557 n,
558 0,
398d8ee1 559 FUNC_NAME);
80662eda
MD		 560 slot_name = SCM_CAR (slot_name);
561 if (tmp)
562 {
563 /* an initarg was provided for this slot */
c598539a 564 if (!scm_is_keyword (tmp))
398d8ee1 565 SCM_MISC_ERROR ("initarg must be a keyword. It was ~S",
1afff620 566 scm_list_1 (tmp));
80662eda
MD		 567 slot_value = scm_i_get_keyword (tmp,
568 initargs,
569 n_initargs,
570 0,
398d8ee1 571 FUNC_NAME);
80662eda
MD		 572 }
573 }
574
575 if (slot_value)
576 /* set slot to provided value */
577 set_slot_value (class, obj, SCM_CAR (get_n_set), slot_value);
578 else
579 {
580 /* set slot to its :init-form if it exists */
581 tmp = SCM_CADAR (get_n_set);
7888309b 582 if (scm_is_true (tmp))
80662eda
MD		 583 {
584 slot_value = get_slot_value (class, obj, SCM_CAR (get_n_set));
585 if (SCM_GOOPS_UNBOUNDP (slot_value))
586 {
587 SCM env = SCM_EXTEND_ENV (SCM_EOL, SCM_EOL, SCM_ENV (tmp));
588 set_slot_value (class,
589 obj,
590 SCM_CAR (get_n_set),
f9450cdb 591 scm_eval_body (SCM_CLOSURE_BODY (tmp), env));
80662eda
MD		 592 }
593 }
594 }
595 }
6d77c894 596
80662eda
MD		 597 return obj;
598}
398d8ee1 599#undef FUNC_NAME
80662eda 600
21ab2aeb
MD		 601/* NOTE: The following macros are interdependent with code
602 * in goops.scm:compute-getters-n-setters
603 */
604#define SCM_GNS_INSTANCE_ALLOCATED_P(gns) \
e11e83f3 605 (SCM_I_INUMP (SCM_CDDR (gns)) \
d2e53ed6
MV		 606 || (scm_is_pair (SCM_CDDR (gns)) \
607 && scm_is_pair (SCM_CDDDR (gns)) \
608 && scm_is_pair (SCM_CDDDDR (gns))))
21ab2aeb 609#define SCM_GNS_INDEX(gns) \
e11e83f3
MV		 610 (SCM_I_INUMP (SCM_CDDR (gns)) \
611 ? SCM_I_INUM (SCM_CDDR (gns)) \
612 : scm_to_long (SCM_CAR (SCM_CDDDDR (gns))))
21ab2aeb 613#define SCM_GNS_SIZE(gns) \
e11e83f3 614 (SCM_I_INUMP (SCM_CDDR (gns)) \
21ab2aeb 615 ? 1 \
e11e83f3 616 : scm_to_long (SCM_CADR (SCM_CDDDDR (gns))))
80662eda
MD		 617
618SCM_KEYWORD (k_class, "class");
b46fae00
MD		 619SCM_KEYWORD (k_allocation, "allocation");
620SCM_KEYWORD (k_instance, "instance");
80662eda 621
398d8ee1
KN		 622SCM_DEFINE (scm_sys_prep_layout_x, "%prep-layout!", 1, 0, 0,
623 (SCM class),
624 "")
625#define FUNC_NAME s_scm_sys_prep_layout_x
80662eda 626{
21ab2aeb 627 SCM slots, getters_n_setters, nfields;
6b80d352
DH		 628 unsigned long int n, i;
629 char *s;
cc95e00a 630 SCM layout;
80662eda 631
398d8ee1 632 SCM_VALIDATE_INSTANCE (1, class);
80662eda 633 slots = SCM_SLOT (class, scm_si_slots);
21ab2aeb 634 getters_n_setters = SCM_SLOT (class, scm_si_getters_n_setters);
80662eda 635 nfields = SCM_SLOT (class, scm_si_nfields);
e11e83f3 636 if (!SCM_I_INUMP (nfields) || SCM_I_INUM (nfields) < 0)
398d8ee1 637 SCM_MISC_ERROR ("bad value in nfields slot: ~S",
1afff620 638 scm_list_1 (nfields));
e11e83f3 639 n = 2 * SCM_I_INUM (nfields);
80662eda
MD		 640 if (n < sizeof (SCM_CLASS_CLASS_LAYOUT) - 1
641 && SCM_SUBCLASSP (class, scm_class_class))
398d8ee1 642 SCM_MISC_ERROR ("class object doesn't have enough fields: ~S",
1afff620 643 scm_list_1 (nfields));
6d77c894 644
cc95e00a 645 layout = scm_i_make_string (n, &s);
21ab2aeb 646 i = 0;
d2e53ed6 647 while (scm_is_pair (getters_n_setters))
80662eda 648 {
21ab2aeb 649 if (SCM_GNS_INSTANCE_ALLOCATED_P (SCM_CAR (getters_n_setters)))
b46fae00 650 {
21ab2aeb
MD		 651 SCM type;
652 int len, index, size;
653 char p, a;
654
d2e53ed6 655 if (i >= n || !scm_is_pair (slots))
21ab2aeb
MD		 656 goto inconsistent;
657
658 /* extract slot type */
b46fae00 659 len = scm_ilength (SCM_CDAR (slots));
21ab2aeb
MD		 660 type = scm_i_get_keyword (k_class, SCM_CDAR (slots),
661 len, SCM_BOOL_F, FUNC_NAME);
662 /* determine slot GC protection and access mode */
7888309b 663 if (scm_is_false (type))
6b80d352 664 {
21ab2aeb
MD		 665 p = 'p';
666 a = 'w';
6b80d352
DH		 667 }
668 else
669 {
21ab2aeb 670 if (!SCM_CLASSP (type))
cc95e00a 671 SCM_MISC_ERROR ("bad slot class", SCM_EOL);
21ab2aeb
MD		 672 else if (SCM_SUBCLASSP (type, scm_class_foreign_slot))
673 {
674 if (SCM_SUBCLASSP (type, scm_class_self))
675 p = 's';
676 else if (SCM_SUBCLASSP (type, scm_class_protected))
677 p = 'p';
678 else
679 p = 'u';
680
681 if (SCM_SUBCLASSP (type, scm_class_opaque))
682 a = 'o';
683 else if (SCM_SUBCLASSP (type, scm_class_read_only))
684 a = 'r';
685 else
686 a = 'w';
687 }
688 else
689 {
690 p = 'p';
691 a = 'w';
692 }
693 }
694
695 index = SCM_GNS_INDEX (SCM_CAR (getters_n_setters));
696 if (index != (i >> 1))
697 goto inconsistent;
698 size = SCM_GNS_SIZE (SCM_CAR (getters_n_setters));
699 while (size)
700 {
701 s[i++] = p;
702 s[i++] = a;
703 --size;
6b80d352 704 }
80662eda 705 }
80662eda 706 slots = SCM_CDR (slots);
21ab2aeb
MD		 707 getters_n_setters = SCM_CDR (getters_n_setters);
708 }
d2e53ed6 709 if (!scm_is_null (slots))
21ab2aeb
MD		 710 {
711 inconsistent:
21ab2aeb 712 SCM_MISC_ERROR ("inconsistent getters-n-setters", SCM_EOL);
80662eda 713 }
cc95e00a 714 SCM_SET_SLOT (class, scm_si_layout, scm_string_to_symbol (layout));
80662eda
MD		 715 return SCM_UNSPECIFIED;
716}
398d8ee1 717#undef FUNC_NAME
80662eda
MD		 718
719static void prep_hashsets (SCM);
720
398d8ee1
KN		 721SCM_DEFINE (scm_sys_inherit_magic_x, "%inherit-magic!", 2, 0, 0,
722 (SCM class, SCM dsupers),
723 "")
724#define FUNC_NAME s_scm_sys_inherit_magic_x
80662eda
MD		 725{
726 SCM ls = dsupers;
c014a02e 727 long flags = 0;
398d8ee1 728 SCM_VALIDATE_INSTANCE (1, class);
d2e53ed6 729 while (!scm_is_null (ls))
80662eda 730 {
d2e53ed6 731 SCM_ASSERT (scm_is_pair (ls)
80662eda
MD		 732 && SCM_INSTANCEP (SCM_CAR (ls)),
733 dsupers,
734 SCM_ARG2,
398d8ee1 735 FUNC_NAME);
80662eda
MD		 736 flags |= SCM_CLASS_FLAGS (SCM_CAR (ls));
737 ls = SCM_CDR (ls);
738 }
739 flags &= SCM_CLASSF_INHERIT;
077644c8
LC		 740
741 if (! (flags & SCM_CLASSF_ENTITY))
80662eda 742 {
e11e83f3 743 long n = SCM_I_INUM (SCM_SLOT (class, scm_si_nfields));
80662eda
MD		 744#if 0
745 /*
4c9419ac 746 * We could avoid calling scm_gc_malloc in the allocation code
80662eda
MD		 747 * (in which case the following two lines are needed). Instead
748 * we make 0-slot instances non-light, so that the light case
749 * can be handled without special cases.
750 */
751 if (n == 0)
752 SCM_SET_CLASS_DESTRUCTOR (class, scm_struct_free_0);
753#endif
754 if (n > 0 && !(flags & SCM_CLASSF_METACLASS))
755 {
756 /* NOTE: The following depends on scm_struct_i_size. */
757 flags |= SCM_STRUCTF_LIGHT + n * sizeof (SCM); /* use light representation */
80662eda
MD		 758 }
759 }
760 SCM_SET_CLASS_FLAGS (class, flags);
761
762 prep_hashsets (class);
6d77c894 763
80662eda
MD		 764 return SCM_UNSPECIFIED;
765}
398d8ee1 766#undef FUNC_NAME
80662eda 767
63c1872f 768static void
80662eda
MD		 769prep_hashsets (SCM class)
770{
dcb410ec 771 unsigned int i;
80662eda
MD		 772
773 for (i = 0; i < 7; ++i)
dcb410ec 774 SCM_SET_HASHSET (class, i, scm_c_uniform32 (goops_rstate));
80662eda
MD		 775}
776
777/******************************************************************************/
778
779SCM
780scm_basic_basic_make_class (SCM class, SCM name, SCM dsupers, SCM dslots)
781{
782 SCM z, cpl, slots, nfields, g_n_s;
783
784 /* Allocate one instance */
785 z = scm_make_struct (class, SCM_INUM0, SCM_EOL);
786
787 /* Initialize its slots */
dcb410ec 788 SCM_SET_SLOT (z, scm_si_direct_supers, dsupers);
80662eda
MD		 789 cpl = compute_cpl (z);
790 slots = build_slots_list (maplist (dslots), cpl);
e11e83f3 791 nfields = scm_from_int (scm_ilength (slots));
80662eda
MD		 792 g_n_s = compute_getters_n_setters (slots);
793
dcb410ec
DH		 794 SCM_SET_SLOT (z, scm_si_name, name);
795 SCM_SET_SLOT (z, scm_si_direct_slots, dslots);
796 SCM_SET_SLOT (z, scm_si_direct_subclasses, SCM_EOL);
797 SCM_SET_SLOT (z, scm_si_direct_methods, SCM_EOL);
798 SCM_SET_SLOT (z, scm_si_cpl, cpl);
799 SCM_SET_SLOT (z, scm_si_slots, slots);
800 SCM_SET_SLOT (z, scm_si_nfields, nfields);
801 SCM_SET_SLOT (z, scm_si_getters_n_setters, g_n_s);
802 SCM_SET_SLOT (z, scm_si_redefined, SCM_BOOL_F);
803 SCM_SET_SLOT (z, scm_si_environment,
804 scm_top_level_env (SCM_TOP_LEVEL_LOOKUP_CLOSURE));
80662eda
MD		 805
806 /* Add this class in the direct-subclasses slot of dsupers */
807 {
808 SCM tmp;
d2e53ed6 809 for (tmp = dsupers; !scm_is_null (tmp); tmp = SCM_CDR (tmp))
dcb410ec
DH		 810 SCM_SET_SLOT (SCM_CAR (tmp), scm_si_direct_subclasses,
811 scm_cons (z, SCM_SLOT (SCM_CAR (tmp),
812 scm_si_direct_subclasses)));
80662eda
MD		 813 }
814
815 /* Support for the underlying structs: */
816 SCM_SET_CLASS_FLAGS (z, (class == scm_class_entity_class
817 ? (SCM_CLASSF_GOOPS_OR_VALID
818 | SCM_CLASSF_OPERATOR
819 | SCM_CLASSF_ENTITY)
820 : class == scm_class_operator_class
821 ? SCM_CLASSF_GOOPS_OR_VALID | SCM_CLASSF_OPERATOR
822 : SCM_CLASSF_GOOPS_OR_VALID));
823 return z;
824}
825
826SCM
827scm_basic_make_class (SCM class, SCM name, SCM dsupers, SCM dslots)
828{
829 SCM z = scm_basic_basic_make_class (class, name, dsupers, dslots);
830 scm_sys_inherit_magic_x (z, dsupers);
831 scm_sys_prep_layout_x (z);
832 return z;
833}
834
835/******************************************************************************/
836
6b80d352
DH		 837SCM_SYMBOL (sym_layout, "layout");
838SCM_SYMBOL (sym_vcell, "vcell");
839SCM_SYMBOL (sym_vtable, "vtable");
840SCM_SYMBOL (sym_print, "print");
841SCM_SYMBOL (sym_procedure, "procedure");
842SCM_SYMBOL (sym_setter, "setter");
843SCM_SYMBOL (sym_redefined, "redefined");
844SCM_SYMBOL (sym_h0, "h0");
845SCM_SYMBOL (sym_h1, "h1");
846SCM_SYMBOL (sym_h2, "h2");
847SCM_SYMBOL (sym_h3, "h3");
848SCM_SYMBOL (sym_h4, "h4");
849SCM_SYMBOL (sym_h5, "h5");
850SCM_SYMBOL (sym_h6, "h6");
851SCM_SYMBOL (sym_h7, "h7");
852SCM_SYMBOL (sym_name, "name");
853SCM_SYMBOL (sym_direct_supers, "direct-supers");
854SCM_SYMBOL (sym_direct_slots, "direct-slots");
855SCM_SYMBOL (sym_direct_subclasses, "direct-subclasses");
856SCM_SYMBOL (sym_direct_methods, "direct-methods");
857SCM_SYMBOL (sym_cpl, "cpl");
858SCM_SYMBOL (sym_default_slot_definition_class, "default-slot-definition-class");
859SCM_SYMBOL (sym_slots, "slots");
860SCM_SYMBOL (sym_getters_n_setters, "getters-n-setters");
861SCM_SYMBOL (sym_keyword_access, "keyword-access");
862SCM_SYMBOL (sym_nfields, "nfields");
863SCM_SYMBOL (sym_environment, "environment");
864
865
80662eda
MD		 866static SCM
867build_class_class_slots ()
868{
6b80d352
DH		 869 return scm_list_n (
870 scm_list_3 (sym_layout, k_class, scm_class_protected_read_only),
6b80d352
DH		 871 scm_list_3 (sym_vtable, k_class, scm_class_self),
872 scm_list_1 (sym_print),
873 scm_list_3 (sym_procedure, k_class, scm_class_protected_opaque),
874 scm_list_3 (sym_setter, k_class, scm_class_protected_opaque),
875 scm_list_1 (sym_redefined),
876 scm_list_3 (sym_h0, k_class, scm_class_int),
877 scm_list_3 (sym_h1, k_class, scm_class_int),
878 scm_list_3 (sym_h2, k_class, scm_class_int),
879 scm_list_3 (sym_h3, k_class, scm_class_int),
880 scm_list_3 (sym_h4, k_class, scm_class_int),
881 scm_list_3 (sym_h5, k_class, scm_class_int),
882 scm_list_3 (sym_h6, k_class, scm_class_int),
883 scm_list_3 (sym_h7, k_class, scm_class_int),
884 scm_list_1 (sym_name),
885 scm_list_1 (sym_direct_supers),
886 scm_list_1 (sym_direct_slots),
887 scm_list_1 (sym_direct_subclasses),
888 scm_list_1 (sym_direct_methods),
889 scm_list_1 (sym_cpl),
890 scm_list_1 (sym_default_slot_definition_class),
891 scm_list_1 (sym_slots),
892 scm_list_1 (sym_getters_n_setters),
893 scm_list_1 (sym_keyword_access),
894 scm_list_1 (sym_nfields),
895 scm_list_1 (sym_environment),
896 SCM_UNDEFINED);
80662eda
MD		 897}
898
899static void
900create_basic_classes (void)
901{
902 /* SCM slots_of_class = build_class_class_slots (); */
903
904 /**** <scm_class_class> ****/
cc95e00a
MV		 905 SCM cs = scm_from_locale_string (SCM_CLASS_CLASS_LAYOUT
906 + 2 * scm_vtable_offset_user);
907 SCM name = scm_from_locale_symbol ("<class>");
80662eda
MD		 908 scm_class_class = scm_permanent_object (scm_make_vtable_vtable (cs,
909 SCM_INUM0,
910 SCM_EOL));
911 SCM_SET_CLASS_FLAGS (scm_class_class, (SCM_CLASSF_GOOPS_OR_VALID
912 | SCM_CLASSF_METACLASS));
913
dcb410ec
DH		 914 SCM_SET_SLOT (scm_class_class, scm_si_name, name);
915 SCM_SET_SLOT (scm_class_class, scm_si_direct_supers, SCM_EOL); /* will be changed */
916 /* SCM_SET_SLOT (scm_class_class, scm_si_direct_slots, slots_of_class); */
917 SCM_SET_SLOT (scm_class_class, scm_si_direct_subclasses, SCM_EOL);
6d77c894 918 SCM_SET_SLOT (scm_class_class, scm_si_direct_methods, SCM_EOL);
dcb410ec
DH		 919 SCM_SET_SLOT (scm_class_class, scm_si_cpl, SCM_EOL); /* will be changed */
920 /* SCM_SET_SLOT (scm_class_class, scm_si_slots, slots_of_class); */
e11e83f3 921 SCM_SET_SLOT (scm_class_class, scm_si_nfields, scm_from_int (SCM_N_CLASS_SLOTS));
dcb410ec
DH		 922 /* SCM_SET_SLOT (scm_class_class, scm_si_getters_n_setters,
923 compute_getters_n_setters (slots_of_class)); */
924 SCM_SET_SLOT (scm_class_class, scm_si_redefined, SCM_BOOL_F);
925 SCM_SET_SLOT (scm_class_class, scm_si_environment,
926 scm_top_level_env (SCM_TOP_LEVEL_LOOKUP_CLOSURE));
80662eda
MD		 927
928 prep_hashsets (scm_class_class);
929
930 DEFVAR(name, scm_class_class);
931
932 /**** <scm_class_top> ****/
cc95e00a 933 name = scm_from_locale_symbol ("<top>");
80662eda
MD		 934 scm_class_top = scm_permanent_object (scm_basic_make_class (scm_class_class,
935 name,
936 SCM_EOL,
937 SCM_EOL));
938
939 DEFVAR(name, scm_class_top);
6d77c894 940
80662eda 941 /**** <scm_class_object> ****/
cc95e00a 942 name = scm_from_locale_symbol ("<object>");
80662eda
MD		 943 scm_class_object = scm_permanent_object (scm_basic_make_class (scm_class_class,
944 name,
1afff620 945 scm_list_1 (scm_class_top),
80662eda
MD		 946 SCM_EOL));
947
948 DEFVAR (name, scm_class_object);
949
950 /* <top> <object> and <class> were partially initialized. Correct them here */
1afff620 951 SCM_SET_SLOT (scm_class_object, scm_si_direct_subclasses, scm_list_1 (scm_class_class));
80662eda 952
1afff620
KN		 953 SCM_SET_SLOT (scm_class_class, scm_si_direct_supers, scm_list_1 (scm_class_object));
954 SCM_SET_SLOT (scm_class_class, scm_si_cpl, scm_list_3 (scm_class_class, scm_class_object, scm_class_top));
80662eda
MD		 955}
956
957/******************************************************************************/
958
398d8ee1
KN		 959SCM_DEFINE (scm_instance_p, "instance?", 1, 0, 0,
960 (SCM obj),
6bcefd15 961 "Return @code{#t} if @var{obj} is an instance.")
398d8ee1 962#define FUNC_NAME s_scm_instance_p
80662eda 963{
7888309b 964 return scm_from_bool (SCM_INSTANCEP (obj));
80662eda 965}
398d8ee1 966#undef FUNC_NAME
80662eda 967
80662eda
MD		 968
969/******************************************************************************
6d77c894 970 *
80662eda
MD		 971 * Meta object accessors
972 *
973 ******************************************************************************/
398d8ee1
KN		 974SCM_DEFINE (scm_class_name, "class-name", 1, 0, 0,
975 (SCM obj),
6bcefd15 976 "Return the class name of @var{obj}.")
398d8ee1 977#define FUNC_NAME s_scm_class_name
80662eda 978{
398d8ee1 979 SCM_VALIDATE_CLASS (1, obj);
6b80d352 980 return scm_slot_ref (obj, sym_name);
80662eda 981}
398d8ee1 982#undef FUNC_NAME
80662eda 983
398d8ee1
KN		 984SCM_DEFINE (scm_class_direct_supers, "class-direct-supers", 1, 0, 0,
985 (SCM obj),
6bcefd15 986 "Return the direct superclasses of the class @var{obj}.")
398d8ee1 987#define FUNC_NAME s_scm_class_direct_supers
80662eda 988{
398d8ee1 989 SCM_VALIDATE_CLASS (1, obj);
6b80d352 990 return scm_slot_ref (obj, sym_direct_supers);
80662eda 991}
398d8ee1 992#undef FUNC_NAME
80662eda 993
398d8ee1
KN		 994SCM_DEFINE (scm_class_direct_slots, "class-direct-slots", 1, 0, 0,
995 (SCM obj),
6bcefd15 996 "Return the direct slots of the class @var{obj}.")
398d8ee1 997#define FUNC_NAME s_scm_class_direct_slots
80662eda 998{
398d8ee1 999 SCM_VALIDATE_CLASS (1, obj);
6b80d352 1000 return scm_slot_ref (obj, sym_direct_slots);
80662eda 1001}
398d8ee1 1002#undef FUNC_NAME
80662eda 1003
398d8ee1
KN		 1004SCM_DEFINE (scm_class_direct_subclasses, "class-direct-subclasses", 1, 0, 0,
1005 (SCM obj),
6bcefd15 1006 "Return the direct subclasses of the class @var{obj}.")
398d8ee1 1007#define FUNC_NAME s_scm_class_direct_subclasses
80662eda 1008{
398d8ee1 1009 SCM_VALIDATE_CLASS (1, obj);
6b80d352 1010 return scm_slot_ref(obj, sym_direct_subclasses);
80662eda 1011}
398d8ee1 1012#undef FUNC_NAME
80662eda 1013
398d8ee1
KN		 1014SCM_DEFINE (scm_class_direct_methods, "class-direct-methods", 1, 0, 0,
1015 (SCM obj),
6bcefd15 1016 "Return the direct methods of the class @var{obj}")
398d8ee1 1017#define FUNC_NAME s_scm_class_direct_methods
80662eda 1018{
398d8ee1 1019 SCM_VALIDATE_CLASS (1, obj);
6b80d352 1020 return scm_slot_ref (obj, sym_direct_methods);
80662eda 1021}
398d8ee1 1022#undef FUNC_NAME
80662eda 1023
398d8ee1
KN		 1024SCM_DEFINE (scm_class_precedence_list, "class-precedence-list", 1, 0, 0,
1025 (SCM obj),
6bcefd15 1026 "Return the class precedence list of the class @var{obj}.")
398d8ee1 1027#define FUNC_NAME s_scm_class_precedence_list
80662eda 1028{
398d8ee1 1029 SCM_VALIDATE_CLASS (1, obj);
6b80d352 1030 return scm_slot_ref (obj, sym_cpl);
80662eda 1031}
398d8ee1 1032#undef FUNC_NAME
80662eda 1033
398d8ee1
KN		 1034SCM_DEFINE (scm_class_slots, "class-slots", 1, 0, 0,
1035 (SCM obj),
6bcefd15 1036 "Return the slot list of the class @var{obj}.")
398d8ee1 1037#define FUNC_NAME s_scm_class_slots
80662eda 1038{
398d8ee1 1039 SCM_VALIDATE_CLASS (1, obj);
6b80d352 1040 return scm_slot_ref (obj, sym_slots);
80662eda 1041}
398d8ee1 1042#undef FUNC_NAME
80662eda 1043
398d8ee1
KN		 1044SCM_DEFINE (scm_class_environment, "class-environment", 1, 0, 0,
1045 (SCM obj),
6bcefd15 1046 "Return the environment of the class @var{obj}.")
398d8ee1 1047#define FUNC_NAME s_scm_class_environment
80662eda 1048{
398d8ee1 1049 SCM_VALIDATE_CLASS (1, obj);
6b80d352 1050 return scm_slot_ref(obj, sym_environment);
80662eda 1051}
398d8ee1 1052#undef FUNC_NAME
80662eda
MD		 1053
1054
398d8ee1
KN		 1055SCM_DEFINE (scm_generic_function_name, "generic-function-name", 1, 0, 0,
1056 (SCM obj),
6bcefd15 1057 "Return the name of the generic function @var{obj}.")
398d8ee1 1058#define FUNC_NAME s_scm_generic_function_name
80662eda 1059{
398d8ee1 1060 SCM_VALIDATE_GENERIC (1, obj);
80662eda
MD		 1061 return scm_procedure_property (obj, scm_sym_name);
1062}
398d8ee1 1063#undef FUNC_NAME
80662eda 1064
bbf8d523
MD		 1065SCM_SYMBOL (sym_methods, "methods");
1066SCM_SYMBOL (sym_extended_by, "extended-by");
1067SCM_SYMBOL (sym_extends, "extends");
1068
1069static
1070SCM fold_downward_gf_methods (SCM method_lists, SCM gf)
1071{
1072 SCM gfs = scm_slot_ref (gf, sym_extended_by);
1073 method_lists = scm_cons (scm_slot_ref (gf, sym_methods), method_lists);
d2e53ed6 1074 while (!scm_is_null (gfs))
bbf8d523
MD		 1075 {
1076 method_lists = fold_downward_gf_methods (method_lists, SCM_CAR (gfs));
1077 gfs = SCM_CDR (gfs);
1078 }
1079 return method_lists;
1080}
1081
1082static
1083SCM fold_upward_gf_methods (SCM method_lists, SCM gf)
1084{
1085 if (SCM_IS_A_P (gf, scm_class_extended_generic))
1086 {
1087 SCM gfs = scm_slot_ref (gf, sym_extends);
d2e53ed6 1088 while (!scm_is_null (gfs))
bbf8d523
MD		 1089 {
1090 SCM methods = scm_slot_ref (SCM_CAR (gfs), sym_methods);
1091 method_lists = fold_upward_gf_methods (scm_cons (methods,
1092 method_lists),
1093 SCM_CAR (gfs));
1094 gfs = SCM_CDR (gfs);
1095 }
1096 }
1097 return method_lists;
1098}
1099
398d8ee1
KN		 1100SCM_DEFINE (scm_generic_function_methods, "generic-function-methods", 1, 0, 0,
1101 (SCM obj),
6bcefd15 1102 "Return the methods of the generic function @var{obj}.")
398d8ee1 1103#define FUNC_NAME s_scm_generic_function_methods
80662eda 1104{
bbf8d523 1105 SCM methods;
398d8ee1 1106 SCM_VALIDATE_GENERIC (1, obj);
bbf8d523
MD		 1107 methods = fold_upward_gf_methods (SCM_EOL, obj);
1108 methods = fold_downward_gf_methods (methods, obj);
1109 return scm_append (methods);
80662eda 1110}
398d8ee1 1111#undef FUNC_NAME
80662eda 1112
398d8ee1
KN		 1113SCM_DEFINE (scm_method_generic_function, "method-generic-function", 1, 0, 0,
1114 (SCM obj),
bb2c02f2 1115 "Return the generic function for the method @var{obj}.")
398d8ee1 1116#define FUNC_NAME s_scm_method_generic_function
80662eda 1117{
398d8ee1 1118 SCM_VALIDATE_METHOD (1, obj);
cc95e00a 1119 return scm_slot_ref (obj, scm_from_locale_symbol ("generic-function"));
80662eda 1120}
398d8ee1 1121#undef FUNC_NAME
80662eda 1122
398d8ee1
KN		 1123SCM_DEFINE (scm_method_specializers, "method-specializers", 1, 0, 0,
1124 (SCM obj),
6bcefd15 1125 "Return specializers of the method @var{obj}.")
398d8ee1 1126#define FUNC_NAME s_scm_method_specializers
80662eda 1127{
398d8ee1 1128 SCM_VALIDATE_METHOD (1, obj);
cc95e00a 1129 return scm_slot_ref (obj, scm_from_locale_symbol ("specializers"));
80662eda 1130}
398d8ee1 1131#undef FUNC_NAME
80662eda 1132
398d8ee1
KN		 1133SCM_DEFINE (scm_method_procedure, "method-procedure", 1, 0, 0,
1134 (SCM obj),
6bcefd15 1135 "Return the procedure of the method @var{obj}.")
398d8ee1 1136#define FUNC_NAME s_scm_method_procedure
80662eda 1137{
398d8ee1 1138 SCM_VALIDATE_METHOD (1, obj);
6b80d352 1139 return scm_slot_ref (obj, sym_procedure);
80662eda 1140}
398d8ee1 1141#undef FUNC_NAME
80662eda 1142
398d8ee1
KN		 1143SCM_DEFINE (scm_accessor_method_slot_definition, "accessor-method-slot-definition", 1, 0, 0,
1144 (SCM obj),
6bcefd15 1145 "Return the slot definition of the accessor @var{obj}.")
398d8ee1 1146#define FUNC_NAME s_scm_accessor_method_slot_definition
80662eda 1147{
398d8ee1 1148 SCM_VALIDATE_ACCESSOR (1, obj);
cc95e00a 1149 return scm_slot_ref (obj, scm_from_locale_symbol ("slot-definition"));
398d8ee1
KN		 1150}
1151#undef FUNC_NAME
80662eda 1152
5e03762c
MD		 1153SCM_DEFINE (scm_sys_tag_body, "%tag-body", 1, 0, 0,
1154 (SCM body),
87e7741d 1155 "Internal GOOPS magic---don't use this function!")
5e03762c
MD		 1156#define FUNC_NAME s_scm_sys_tag_body
1157{
1158 return scm_cons (SCM_IM_LAMBDA, body);
87e7741d
MD		 1159}
1160#undef FUNC_NAME
80662eda
MD		 1161
1162/******************************************************************************
1163 *
1164 * S l o t a c c e s s
1165 *
1166 ******************************************************************************/
1167
398d8ee1
KN		 1168SCM_DEFINE (scm_make_unbound, "make-unbound", 0, 0, 0,
1169 (),
6bcefd15 1170 "Return the unbound value.")
398d8ee1 1171#define FUNC_NAME s_scm_make_unbound
80662eda
MD		 1172{
1173 return SCM_GOOPS_UNBOUND;
1174}
398d8ee1 1175#undef FUNC_NAME
80662eda 1176
398d8ee1
KN		 1177SCM_DEFINE (scm_unbound_p, "unbound?", 1, 0, 0,
1178 (SCM obj),
6bcefd15 1179 "Return @code{#t} if @var{obj} is unbound.")
398d8ee1 1180#define FUNC_NAME s_scm_unbound_p
80662eda
MD		 1181{
1182 return SCM_GOOPS_UNBOUNDP (obj) ? SCM_BOOL_T : SCM_BOOL_F;
1183}
398d8ee1 1184#undef FUNC_NAME
80662eda 1185
398d8ee1
KN		 1186SCM_DEFINE (scm_assert_bound, "assert-bound", 2, 0, 0,
1187 (SCM value, SCM obj),
6bcefd15
MG		 1188 "Return @var{value} if it is bound, and invoke the\n"
1189 "@var{slot-unbound} method of @var{obj} if it is not.")
398d8ee1 1190#define FUNC_NAME s_scm_assert_bound
80662eda
MD		 1191{
1192 if (SCM_GOOPS_UNBOUNDP (value))
1193 return CALL_GF1 ("slot-unbound", obj);
1194 return value;
1195}
398d8ee1 1196#undef FUNC_NAME
80662eda 1197
398d8ee1
KN		 1198SCM_DEFINE (scm_at_assert_bound_ref, "@assert-bound-ref", 2, 0, 0,
1199 (SCM obj, SCM index),
6bcefd15
MG		 1200 "Like @code{assert-bound}, but use @var{index} for accessing\n"
1201 "the value from @var{obj}.")
398d8ee1 1202#define FUNC_NAME s_scm_at_assert_bound_ref
80662eda 1203{
e11e83f3 1204 SCM value = SCM_SLOT (obj, scm_to_int (index));
80662eda
MD		 1205 if (SCM_GOOPS_UNBOUNDP (value))
1206 return CALL_GF1 ("slot-unbound", obj);
1207 return value;
1208}
398d8ee1 1209#undef FUNC_NAME
80662eda 1210
398d8ee1
KN		 1211SCM_DEFINE (scm_sys_fast_slot_ref, "%fast-slot-ref", 2, 0, 0,
1212 (SCM obj, SCM index),
6bcefd15 1213 "Return the slot value with index @var{index} from @var{obj}.")
398d8ee1 1214#define FUNC_NAME s_scm_sys_fast_slot_ref
80662eda 1215{
6b80d352 1216 unsigned long int i;
80662eda 1217
398d8ee1 1218 SCM_VALIDATE_INSTANCE (1, obj);
a9931e4e
NJ		 1219 i = scm_to_unsigned_integer (index, 0,
1220 SCM_I_INUM (SCM_SLOT (SCM_CLASS_OF (obj),
1221 scm_si_nfields))
1222 - 1);
58241edc 1223 return SCM_SLOT (obj, i);
80662eda 1224}
ca83b028
DH		 1225#undef FUNC_NAME
1226
398d8ee1
KN		 1227SCM_DEFINE (scm_sys_fast_slot_set_x, "%fast-slot-set!", 3, 0, 0,
1228 (SCM obj, SCM index, SCM value),
6bcefd15
MG		 1229 "Set the slot with index @var{index} in @var{obj} to\n"
1230 "@var{value}.")
398d8ee1 1231#define FUNC_NAME s_scm_sys_fast_slot_set_x
80662eda 1232{
6b80d352 1233 unsigned long int i;
80662eda 1234
398d8ee1 1235 SCM_VALIDATE_INSTANCE (1, obj);
a9931e4e
NJ		 1236 i = scm_to_unsigned_integer (index, 0,
1237 SCM_I_INUM (SCM_SLOT (SCM_CLASS_OF (obj),
1238 scm_si_nfields))
1239 - 1);
6b80d352 1240
dcb410ec 1241 SCM_SET_SLOT (obj, i, value);
ca83b028 1242
80662eda
MD		 1243 return SCM_UNSPECIFIED;
1244}
ca83b028
DH		 1245#undef FUNC_NAME
1246
80662eda 1247
3b88ed2a
DH		 1248SCM_SYNTAX (s_atslot_ref, "@slot-ref", scm_i_makbimacro, scm_m_atslot_ref);
1249SCM_SYNTAX (s_atslot_set_x, "@slot-set!", scm_i_makbimacro, scm_m_atslot_set_x);
a4aa2134
DH		 1250
1251
80662eda
MD		 1252/** Utilities **/
1253
1254/* In the future, this function will return the effective slot
1255 * definition associated with SLOT_NAME. Now it just returns some of
1256 * the information which will be stored in the effective slot
1257 * definition.
1258 */
1259
1260static SCM
1261slot_definition_using_name (SCM class, SCM slot_name)
1262{
1263 register SCM slots = SCM_SLOT (class, scm_si_getters_n_setters);
d2e53ed6 1264 for (; !scm_is_null (slots); slots = SCM_CDR (slots))
80662eda
MD		 1265 if (SCM_CAAR (slots) == slot_name)
1266 return SCM_CAR (slots);
1267 return SCM_BOOL_F;
1268}
1269
1270static SCM
e81d98ec 1271get_slot_value (SCM class SCM_UNUSED, SCM obj, SCM slotdef)
54ee7cdf 1272#define FUNC_NAME "%get-slot-value"
80662eda
MD		 1273{
1274 SCM access = SCM_CDDR (slotdef);
1275 /* Two cases here:
1276 * - access is an integer (the offset of this slot in the slots vector)
1277 * - otherwise (car access) is the getter function to apply
e11e83f3
MV		 1278 *
1279 * Instances have never more than SCM_MOST_POSITIVE_FIXNUM slots, so
1280 * we can just assume fixnums here.
23437298 1281 */
e11e83f3 1282 if (SCM_I_INUMP (access))
54ee7cdf
AW		 1283 /* Don't poke at the slots directly, because scm_struct_ref handles the
1284 access bits for us. */
1285 return scm_struct_ref (obj, access);
80662eda
MD		 1286 else
1287 {
6d77c894 1288 /* We must evaluate (apply (car access) (list obj))
80662eda
MD		 1289 * where (car access) is known to be a closure of arity 1 */
1290 register SCM code, env;
1291
1292 code = SCM_CAR (access);
1293 if (!SCM_CLOSUREP (code))
1294 return SCM_SUBRF (code) (obj);
726d810a 1295 env = SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (code),
1afff620 1296 scm_list_1 (obj),
80662eda
MD		 1297 SCM_ENV (code));
1298 /* Evaluate the closure body */
f9450cdb 1299 return scm_eval_body (SCM_CLOSURE_BODY (code), env);
80662eda
MD		 1300 }
1301}
54ee7cdf 1302#undef FUNC_NAME
80662eda
MD		 1303
1304static SCM
1305get_slot_value_using_name (SCM class, SCM obj, SCM slot_name)
1306{
1307 SCM slotdef = slot_definition_using_name (class, slot_name);
7888309b 1308 if (scm_is_true (slotdef))
80662eda
MD		 1309 return get_slot_value (class, obj, slotdef);
1310 else
1311 return CALL_GF3 ("slot-missing", class, obj, slot_name);
1312}
1313
1314static SCM
e81d98ec 1315set_slot_value (SCM class SCM_UNUSED, SCM obj, SCM slotdef, SCM value)
54ee7cdf 1316#define FUNC_NAME "%set-slot-value"
80662eda
MD		 1317{
1318 SCM access = SCM_CDDR (slotdef);
1319 /* Two cases here:
1320 * - access is an integer (the offset of this slot in the slots vector)
1321 * - otherwise (cadr access) is the setter function to apply
e11e83f3
MV		 1322 *
1323 * Instances have never more than SCM_MOST_POSITIVE_FIXNUM slots, so
1324 * we can just assume fixnums here.
80662eda 1325 */
e11e83f3 1326 if (SCM_I_INUMP (access))
54ee7cdf
AW		 1327 /* obey permissions bits via going through struct-set! */
1328 scm_struct_set_x (obj, access, value);
80662eda
MD		 1329 else
1330 {
1331 /* We must evaluate (apply (cadr l) (list obj value))
1332 * where (cadr l) is known to be a closure of arity 2 */
1333 register SCM code, env;
1334
1335 code = SCM_CADR (access);
1336 if (!SCM_CLOSUREP (code))
1337 SCM_SUBRF (code) (obj, value);
1338 else
1339 {
726d810a 1340 env = SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (code),
1afff620 1341 scm_list_2 (obj, value),
80662eda
MD		 1342 SCM_ENV (code));
1343 /* Evaluate the closure body */
f9450cdb 1344 scm_eval_body (SCM_CLOSURE_BODY (code), env);
80662eda
MD		 1345 }
1346 }
1347 return SCM_UNSPECIFIED;
1348}
54ee7cdf 1349#undef FUNC_NAME
80662eda
MD		 1350
1351static SCM
1352set_slot_value_using_name (SCM class, SCM obj, SCM slot_name, SCM value)
1353{
1354 SCM slotdef = slot_definition_using_name (class, slot_name);
7888309b 1355 if (scm_is_true (slotdef))
80662eda
MD		 1356 return set_slot_value (class, obj, slotdef, value);
1357 else
1358 return CALL_GF4 ("slot-missing", class, obj, slot_name, value);
1359}
1360
1361static SCM
e81d98ec 1362test_slot_existence (SCM class SCM_UNUSED, SCM obj, SCM slot_name)
80662eda
MD		 1363{
1364 register SCM l;
1365
d2e53ed6 1366 for (l = SCM_ACCESSORS_OF (obj); !scm_is_null (l); l = SCM_CDR (l))
bc36d050 1367 if (scm_is_eq (SCM_CAAR (l), slot_name))
80662eda
MD		 1368 return SCM_BOOL_T;
1369
1370 return SCM_BOOL_F;
1371}
1372
80662eda
MD		 1373 /* ======================================== */
1374
23437298
DH		 1375SCM_DEFINE (scm_slot_ref_using_class, "slot-ref-using-class", 3, 0, 0,
1376 (SCM class, SCM obj, SCM slot_name),
1377 "")
1378#define FUNC_NAME s_scm_slot_ref_using_class
80662eda
MD		 1379{
1380 SCM res;
1381
398d8ee1
KN		 1382 SCM_VALIDATE_CLASS (1, class);
1383 SCM_VALIDATE_INSTANCE (2, obj);
1384 SCM_VALIDATE_SYMBOL (3, slot_name);
80662eda
MD		 1385
1386 res = get_slot_value_using_name (class, obj, slot_name);
1387 if (SCM_GOOPS_UNBOUNDP (res))
1388 return CALL_GF3 ("slot-unbound", class, obj, slot_name);
1389 return res;
1390}
23437298 1391#undef FUNC_NAME
80662eda 1392
23437298
DH		 1393
1394SCM_DEFINE (scm_slot_set_using_class_x, "slot-set-using-class!", 4, 0, 0,
1395 (SCM class, SCM obj, SCM slot_name, SCM value),
1396 "")
1397#define FUNC_NAME s_scm_slot_set_using_class_x
80662eda 1398{
398d8ee1
KN		 1399 SCM_VALIDATE_CLASS (1, class);
1400 SCM_VALIDATE_INSTANCE (2, obj);
1401 SCM_VALIDATE_SYMBOL (3, slot_name);
23437298 1402
80662eda
MD		 1403 return set_slot_value_using_name (class, obj, slot_name, value);
1404}
23437298
DH		 1405#undef FUNC_NAME
1406
80662eda 1407
398d8ee1
KN		 1408SCM_DEFINE (scm_slot_bound_using_class_p, "slot-bound-using-class?", 3, 0, 0,
1409 (SCM class, SCM obj, SCM slot_name),
1410 "")
1411#define FUNC_NAME s_scm_slot_bound_using_class_p
80662eda 1412{
398d8ee1
KN		 1413 SCM_VALIDATE_CLASS (1, class);
1414 SCM_VALIDATE_INSTANCE (2, obj);
1415 SCM_VALIDATE_SYMBOL (3, slot_name);
80662eda
MD		 1416
1417 return (SCM_GOOPS_UNBOUNDP (get_slot_value_using_name (class, obj, slot_name))
1418 ? SCM_BOOL_F
1419 : SCM_BOOL_T);
1420}
398d8ee1 1421#undef FUNC_NAME
80662eda 1422
398d8ee1
KN		 1423SCM_DEFINE (scm_slot_exists_using_class_p, "slot-exists-using-class?", 3, 0, 0,
1424 (SCM class, SCM obj, SCM slot_name),
1425 "")
1426#define FUNC_NAME s_scm_slot_exists_using_class_p
1427{
1428 SCM_VALIDATE_CLASS (1, class);
1429 SCM_VALIDATE_INSTANCE (2, obj);
1430 SCM_VALIDATE_SYMBOL (3, slot_name);
80662eda
MD		 1431 return test_slot_existence (class, obj, slot_name);
1432}
398d8ee1 1433#undef FUNC_NAME
80662eda
MD		 1434
1435
1436 /* ======================================== */
1437
398d8ee1
KN		 1438SCM_DEFINE (scm_slot_ref, "slot-ref", 2, 0, 0,
1439 (SCM obj, SCM slot_name),
6bcefd15
MG		 1440 "Return the value from @var{obj}'s slot with the name\n"
1441 "@var{slot_name}.")
398d8ee1 1442#define FUNC_NAME s_scm_slot_ref
80662eda
MD		 1443{
1444 SCM res, class;
1445
398d8ee1 1446 SCM_VALIDATE_INSTANCE (1, obj);
80662eda
MD		 1447 TEST_CHANGE_CLASS (obj, class);
1448
1449 res = get_slot_value_using_name (class, obj, slot_name);
1450 if (SCM_GOOPS_UNBOUNDP (res))
1451 return CALL_GF3 ("slot-unbound", class, obj, slot_name);
1452 return res;
1453}
398d8ee1 1454#undef FUNC_NAME
80662eda 1455
398d8ee1
KN		 1456SCM_DEFINE (scm_slot_set_x, "slot-set!", 3, 0, 0,
1457 (SCM obj, SCM slot_name, SCM value),
6bcefd15 1458 "Set the slot named @var{slot_name} of @var{obj} to @var{value}.")
398d8ee1 1459#define FUNC_NAME s_scm_slot_set_x
80662eda
MD		 1460{
1461 SCM class;
1462
398d8ee1 1463 SCM_VALIDATE_INSTANCE (1, obj);
80662eda
MD		 1464 TEST_CHANGE_CLASS(obj, class);
1465
1466 return set_slot_value_using_name (class, obj, slot_name, value);
1467}
398d8ee1 1468#undef FUNC_NAME
80662eda 1469
398d8ee1 1470const char *scm_s_slot_set_x = s_scm_slot_set_x;
80662eda 1471
398d8ee1
KN		 1472SCM_DEFINE (scm_slot_bound_p, "slot-bound?", 2, 0, 0,
1473 (SCM obj, SCM slot_name),
6bcefd15
MG		 1474 "Return @code{#t} if the slot named @var{slot_name} of @var{obj}\n"
1475 "is bound.")
398d8ee1 1476#define FUNC_NAME s_scm_slot_bound_p
80662eda
MD		 1477{
1478 SCM class;
1479
398d8ee1 1480 SCM_VALIDATE_INSTANCE (1, obj);
80662eda
MD		 1481 TEST_CHANGE_CLASS(obj, class);
1482
1483 return (SCM_GOOPS_UNBOUNDP (get_slot_value_using_name (class,
1484 obj,
1485 slot_name))
1486 ? SCM_BOOL_F
1487 : SCM_BOOL_T);
1488}
398d8ee1 1489#undef FUNC_NAME
80662eda 1490
6d77c894 1491SCM_DEFINE (scm_slot_exists_p, "slot-exists?", 2, 0, 0,
398d8ee1 1492 (SCM obj, SCM slot_name),
6bcefd15 1493 "Return @code{#t} if @var{obj} has a slot named @var{slot_name}.")
6d77c894 1494#define FUNC_NAME s_scm_slot_exists_p
80662eda
MD		 1495{
1496 SCM class;
1497
398d8ee1
KN		 1498 SCM_VALIDATE_INSTANCE (1, obj);
1499 SCM_VALIDATE_SYMBOL (2, slot_name);
80662eda
MD		 1500 TEST_CHANGE_CLASS (obj, class);
1501
1502 return test_slot_existence (class, obj, slot_name);
1503}
398d8ee1 1504#undef FUNC_NAME
80662eda
MD		 1505
1506
1507/******************************************************************************
1508 *
1509 * %allocate-instance (the low level instance allocation primitive)
1510 *
1511 ******************************************************************************/
1512
1513static void clear_method_cache (SCM);
1514
1515static SCM
c014a02e 1516wrap_init (SCM class, SCM *m, long n)
80662eda 1517{
c014a02e 1518 long i;
4125c767
AW		 1519 scm_t_bits slayout = SCM_STRUCT_DATA (class)[scm_vtable_index_layout];
1520 const char *layout = scm_i_symbol_chars (SCM_PACK (slayout));
6d77c894 1521
4125c767 1522 /* Set all SCM-holding slots to unbound */
80662eda 1523 for (i = 0; i < n; i++)
4125c767
AW		 1524 if (layout[i*2] == 'p')
1525 m[i] = SCM_GOOPS_UNBOUND;
1526 else
1527 m[i] = 0;
80662eda 1528
228a24ef
DH		 1529 return scm_double_cell ((((scm_t_bits) SCM_STRUCT_DATA (class))
1530 | scm_tc3_struct),
1531 (scm_t_bits) m, 0, 0);
80662eda
MD		 1532}
1533
398d8ee1
KN		 1534SCM_DEFINE (scm_sys_allocate_instance, "%allocate-instance", 2, 0, 0,
1535 (SCM class, SCM initargs),
6bcefd15
MG		 1536 "Create a new instance of class @var{class} and initialize it\n"
1537 "from the arguments @var{initargs}.")
398d8ee1 1538#define FUNC_NAME s_scm_sys_allocate_instance
80662eda
MD		 1539{
1540 SCM *m;
c014a02e 1541 long n;
80662eda 1542
398d8ee1 1543 SCM_VALIDATE_CLASS (1, class);
80662eda
MD		 1544
1545 /* Most instances */
1546 if (SCM_CLASS_FLAGS (class) & SCM_STRUCTF_LIGHT)
1547 {
e11e83f3 1548 n = SCM_I_INUM (SCM_SLOT (class, scm_si_nfields));
4c9419ac 1549 m = (SCM *) scm_gc_malloc (n * sizeof (SCM), "struct");
80662eda
MD		 1550 return wrap_init (class, m, n);
1551 }
6d77c894 1552
80662eda
MD		 1553 /* Foreign objects */
1554 if (SCM_CLASS_FLAGS (class) & SCM_CLASSF_FOREIGN)
1555 return scm_make_foreign_object (class, initargs);
1556
e11e83f3 1557 n = SCM_I_INUM (SCM_SLOT (class, scm_si_nfields));
6d77c894 1558
80662eda
MD		 1559 /* Entities */
1560 if (SCM_CLASS_FLAGS (class) & SCM_CLASSF_ENTITY)
1561 {
4c9419ac
MV		 1562 m = (SCM *) scm_alloc_struct (n, scm_struct_entity_n_extra_words,
1563 "entity struct");
80662eda
MD		 1564 m[scm_struct_i_setter] = SCM_BOOL_F;
1565 m[scm_struct_i_procedure] = SCM_BOOL_F;
1566 /* Generic functions */
1567 if (SCM_CLASS_FLAGS (class) & SCM_CLASSF_PURE_GENERIC)
1568 {
1569 SCM gf = wrap_init (class, m, n);
1570 clear_method_cache (gf);
1571 return gf;
1572 }
1573 else
1574 return wrap_init (class, m, n);
1575 }
6d77c894 1576
80662eda
MD		 1577 /* Class objects */
1578 if (SCM_CLASS_FLAGS (class) & SCM_CLASSF_METACLASS)
1579 {
c014a02e 1580 long i;
80662eda
MD		 1581
1582 /* allocate class object */
1583 SCM z = scm_make_struct (class, SCM_INUM0, SCM_EOL);
1584
dcb410ec 1585 SCM_SET_SLOT (z, scm_si_print, SCM_GOOPS_UNBOUND);
80662eda 1586 for (i = scm_si_goops_fields; i < n; i++)
dcb410ec 1587 SCM_SET_SLOT (z, i, SCM_GOOPS_UNBOUND);
80662eda
MD		 1588
1589 if (SCM_SUBCLASSP (class, scm_class_entity_class))
1590 SCM_SET_CLASS_FLAGS (z, SCM_CLASSF_OPERATOR | SCM_CLASSF_ENTITY);
1591 else if (SCM_SUBCLASSP (class, scm_class_operator_class))
1592 SCM_SET_CLASS_FLAGS (z, SCM_CLASSF_OPERATOR);
1593
1594 return z;
1595 }
6d77c894 1596
80662eda
MD		 1597 /* Non-light instances */
1598 {
4c9419ac 1599 m = (SCM *) scm_alloc_struct (n, scm_struct_n_extra_words, "heavy struct");
80662eda
MD		 1600 return wrap_init (class, m, n);
1601 }
1602}
398d8ee1 1603#undef FUNC_NAME
80662eda 1604
398d8ee1
KN		 1605SCM_DEFINE (scm_sys_set_object_setter_x, "%set-object-setter!", 2, 0, 0,
1606 (SCM obj, SCM setter),
1607 "")
1608#define FUNC_NAME s_scm_sys_set_object_setter_x
80662eda 1609{
c312aca7 1610 SCM_ASSERT (SCM_STRUCTP (obj)
80662eda
MD		 1611 && ((SCM_CLASS_FLAGS (obj) & SCM_CLASSF_OPERATOR)
1612 || SCM_I_ENTITYP (obj)),
1613 obj,
1614 SCM_ARG1,
398d8ee1 1615 FUNC_NAME);
80662eda 1616 if (SCM_I_ENTITYP (obj))
322ec19d 1617 SCM_SET_ENTITY_SETTER (obj, setter);
80662eda
MD		 1618 else
1619 SCM_OPERATOR_CLASS (obj)->setter = setter;
1620 return SCM_UNSPECIFIED;
1621}
398d8ee1 1622#undef FUNC_NAME
80662eda
MD		 1623
1624/******************************************************************************
1625 *
1626 * %modify-instance (used by change-class to modify in place)
6d77c894 1627 *
80662eda
MD		 1628 ******************************************************************************/
1629
398d8ee1
KN		 1630SCM_DEFINE (scm_sys_modify_instance, "%modify-instance", 2, 0, 0,
1631 (SCM old, SCM new),
1632 "")
1633#define FUNC_NAME s_scm_sys_modify_instance
80662eda 1634{
398d8ee1
KN		 1635 SCM_VALIDATE_INSTANCE (1, old);
1636 SCM_VALIDATE_INSTANCE (2, new);
80662eda 1637
6d77c894 1638 /* Exchange the data contained in old and new. We exchange rather than
80662eda
MD		 1639 * scratch the old value with new to be correct with GC.
1640 * See "Class redefinition protocol above".
1641 */
9de87eea 1642 SCM_CRITICAL_SECTION_START;
80662eda
MD		 1643 {
1644 SCM car = SCM_CAR (old);
1645 SCM cdr = SCM_CDR (old);
1646 SCM_SETCAR (old, SCM_CAR (new));
1647 SCM_SETCDR (old, SCM_CDR (new));
1648 SCM_SETCAR (new, car);
1649 SCM_SETCDR (new, cdr);
1650 }
9de87eea 1651 SCM_CRITICAL_SECTION_END;
80662eda
MD		 1652 return SCM_UNSPECIFIED;
1653}
398d8ee1 1654#undef FUNC_NAME
80662eda 1655
398d8ee1
KN		 1656SCM_DEFINE (scm_sys_modify_class, "%modify-class", 2, 0, 0,
1657 (SCM old, SCM new),
1658 "")
1659#define FUNC_NAME s_scm_sys_modify_class
80662eda 1660{
398d8ee1
KN		 1661 SCM_VALIDATE_CLASS (1, old);
1662 SCM_VALIDATE_CLASS (2, new);
80662eda 1663
9de87eea 1664 SCM_CRITICAL_SECTION_START;
80662eda
MD		 1665 {
1666 SCM car = SCM_CAR (old);
1667 SCM cdr = SCM_CDR (old);
1668 SCM_SETCAR (old, SCM_CAR (new));
1669 SCM_SETCDR (old, SCM_CDR (new));
729dbac3 1670 SCM_STRUCT_DATA (old)[scm_vtable_index_vtable] = SCM_UNPACK (old);
80662eda
MD		 1671 SCM_SETCAR (new, car);
1672 SCM_SETCDR (new, cdr);
729dbac3 1673 SCM_STRUCT_DATA (new)[scm_vtable_index_vtable] = SCM_UNPACK (new);
80662eda 1674 }
9de87eea 1675 SCM_CRITICAL_SECTION_END;
80662eda
MD		 1676 return SCM_UNSPECIFIED;
1677}
398d8ee1 1678#undef FUNC_NAME
80662eda 1679
398d8ee1
KN		 1680SCM_DEFINE (scm_sys_invalidate_class, "%invalidate-class", 1, 0, 0,
1681 (SCM class),
1682 "")
1683#define FUNC_NAME s_scm_sys_invalidate_class
80662eda 1684{
398d8ee1 1685 SCM_VALIDATE_CLASS (1, class);
80662eda
MD		 1686 SCM_CLEAR_CLASS_FLAGS (class, SCM_CLASSF_GOOPS_VALID);
1687 return SCM_UNSPECIFIED;
1688}
398d8ee1 1689#undef FUNC_NAME
80662eda
MD		 1690
1691/* When instances change class, they finally get a new body, but
1692 * before that, they go through purgatory in hell. Odd as it may
1693 * seem, this data structure saves us from eternal suffering in
1694 * infinite recursions.
1695 */
1696
92c2555f 1697static scm_t_bits **hell;
c014a02e
ML		 1698static long n_hell = 1; /* one place for the evil one himself */
1699static long hell_size = 4;
2132f0d2 1700static SCM hell_mutex;
80662eda 1701
c014a02e 1702static long
80662eda
MD		 1703burnin (SCM o)
1704{
c014a02e 1705 long i;
80662eda 1706 for (i = 1; i < n_hell; ++i)
6b80d352 1707 if (SCM_STRUCT_DATA (o) == hell[i])
80662eda
MD		 1708 return i;
1709 return 0;
1710}
1711
1712static void
1713go_to_hell (void *o)
1714{
6b80d352 1715 SCM obj = SCM_PACK ((scm_t_bits) o);
2132f0d2 1716 scm_lock_mutex (hell_mutex);
51ef99f7 1717 if (n_hell >= hell_size)
80662eda 1718 {
51ef99f7 1719 hell_size *= 2;
408bcd99 1720 hell = scm_realloc (hell, hell_size * sizeof(*hell));
80662eda 1721 }
6b80d352 1722 hell[n_hell++] = SCM_STRUCT_DATA (obj);
2132f0d2 1723 scm_unlock_mutex (hell_mutex);
80662eda
MD		 1724}
1725
1726static void
1727go_to_heaven (void *o)
1728{
2132f0d2 1729 scm_lock_mutex (hell_mutex);
6b80d352 1730 hell[burnin (SCM_PACK ((scm_t_bits) o))] = hell[--n_hell];
2132f0d2 1731 scm_unlock_mutex (hell_mutex);
80662eda
MD		 1732}
1733
6b80d352
DH		 1734
1735SCM_SYMBOL (scm_sym_change_class, "change-class");
1736
80662eda
MD		 1737static SCM
1738purgatory (void *args)
1739{
6d77c894 1740 return scm_apply_0 (GETVAR (scm_sym_change_class),
6b80d352 1741 SCM_PACK ((scm_t_bits) args));
80662eda
MD		 1742}
1743
38d8927c
MD		 1744/* This function calls the generic function change-class for all
1745 * instances which aren't currently undergoing class change.
1746 */
1747
80662eda 1748void
e81d98ec 1749scm_change_object_class (SCM obj, SCM old_class SCM_UNUSED, SCM new_class)
80662eda
MD		 1750{
1751 if (!burnin (obj))
1752 scm_internal_dynamic_wind (go_to_hell, purgatory, go_to_heaven,
6b80d352
DH		 1753 (void *) SCM_UNPACK (scm_list_2 (obj, new_class)),
1754 (void *) SCM_UNPACK (obj));
80662eda
MD		 1755}
1756
1757/******************************************************************************
1758 *
6d77c894
TTN		 1759 * GGGG FFFFF
1760 * G F
1761 * G GG FFF
1762 * G G F
80662eda
MD		 1763 * GGG E N E R I C F U N C T I O N S
1764 *
1765 * This implementation provides
1766 * - generic functions (with class specializers)
1767 * - multi-methods
6d77c894 1768 * - next-method
80662eda
MD		 1769 * - a hard-coded MOP for standard gf, which can be overloaded for non-std gf
1770 *
1771 ******************************************************************************/
1772
1773SCM_KEYWORD (k_name, "name");
1774
1775SCM_SYMBOL (sym_no_method, "no-method");
1776
1777static SCM list_of_no_method;
1778
63c1872f 1779SCM_GLOBAL_SYMBOL (scm_sym_args, "args");
80662eda 1780
a4aa2134 1781
80662eda
MD		 1782SCM
1783scm_make_method_cache (SCM gf)
1784{
1afff620
KN		 1785 return scm_list_5 (SCM_IM_DISPATCH,
1786 scm_sym_args,
e11e83f3 1787 scm_from_int (1),
1afff620
KN		 1788 scm_c_make_vector (SCM_INITIAL_MCACHE_SIZE,
1789 list_of_no_method),
1790 gf);
80662eda
MD		 1791}
1792
1793static void
1794clear_method_cache (SCM gf)
1795{
322ec19d
ML		 1796 SCM cache = scm_make_method_cache (gf);
1797 SCM_SET_ENTITY_PROCEDURE (gf, cache);
dcb410ec 1798 SCM_SET_SLOT (gf, scm_si_used_by, SCM_BOOL_F);
80662eda
MD		 1799}
1800
398d8ee1
KN		 1801SCM_DEFINE (scm_sys_invalidate_method_cache_x, "%invalidate-method-cache!", 1, 0, 0,
1802 (SCM gf),
1803 "")
1804#define FUNC_NAME s_scm_sys_invalidate_method_cache_x
80662eda
MD		 1805{
1806 SCM used_by;
25ba37df 1807 SCM_ASSERT (SCM_PUREGENERICP (gf), gf, SCM_ARG1, FUNC_NAME);
80662eda 1808 used_by = SCM_SLOT (gf, scm_si_used_by);
7888309b 1809 if (scm_is_true (used_by))
80662eda
MD		 1810 {
1811 SCM methods = SCM_SLOT (gf, scm_si_methods);
d2e53ed6 1812 for (; scm_is_pair (used_by); used_by = SCM_CDR (used_by))
80662eda
MD		 1813 scm_sys_invalidate_method_cache_x (SCM_CAR (used_by));
1814 clear_method_cache (gf);
d2e53ed6 1815 for (; scm_is_pair (methods); methods = SCM_CDR (methods))
dcb410ec 1816 SCM_SET_SLOT (SCM_CAR (methods), scm_si_code_table, SCM_EOL);
80662eda
MD		 1817 }
1818 {
55c4a132 1819 SCM n = SCM_SLOT (gf, scm_si_n_specialized);
80662eda 1820 /* The sign of n is a flag indicating rest args. */
55c4a132 1821 SCM_SET_MCACHE_N_SPECIALIZED (SCM_ENTITY_PROCEDURE (gf), n);
80662eda
MD		 1822 }
1823 return SCM_UNSPECIFIED;
1824}
398d8ee1 1825#undef FUNC_NAME
80662eda 1826
398d8ee1
KN		 1827SCM_DEFINE (scm_generic_capability_p, "generic-capability?", 1, 0, 0,
1828 (SCM proc),
1829 "")
1830#define FUNC_NAME s_scm_generic_capability_p
80662eda 1831{
7888309b 1832 SCM_ASSERT (scm_is_true (scm_procedure_p (proc)),
398d8ee1 1833 proc, SCM_ARG1, FUNC_NAME);
80662eda
MD		 1834 return (scm_subr_p (proc) && SCM_SUBR_GENERIC (proc)
1835 ? SCM_BOOL_T
1836 : SCM_BOOL_F);
1837}
398d8ee1 1838#undef FUNC_NAME
80662eda 1839
398d8ee1
KN		 1840SCM_DEFINE (scm_enable_primitive_generic_x, "enable-primitive-generic!", 0, 0, 1,
1841 (SCM subrs),
1842 "")
1843#define FUNC_NAME s_scm_enable_primitive_generic_x
80662eda 1844{
6b80d352 1845 SCM_VALIDATE_REST_ARGUMENT (subrs);
d2e53ed6 1846 while (!scm_is_null (subrs))
80662eda
MD		 1847 {
1848 SCM subr = SCM_CAR (subrs);
1849 SCM_ASSERT (scm_subr_p (subr) && SCM_SUBR_GENERIC (subr),
398d8ee1 1850 subr, SCM_ARGn, FUNC_NAME);
80662eda 1851 *SCM_SUBR_GENERIC (subr)
1afff620
KN		 1852 = scm_make (scm_list_3 (scm_class_generic,
1853 k_name,
1854 SCM_SNAME (subr)));
80662eda
MD		 1855 subrs = SCM_CDR (subrs);
1856 }
1857 return SCM_UNSPECIFIED;
1858}
398d8ee1 1859#undef FUNC_NAME
80662eda 1860
398d8ee1
KN		 1861SCM_DEFINE (scm_primitive_generic_generic, "primitive-generic-generic", 1, 0, 0,
1862 (SCM subr),
1863 "")
1864#define FUNC_NAME s_scm_primitive_generic_generic
80662eda
MD		 1865{
1866 if (scm_subr_p (subr) && SCM_SUBR_GENERIC (subr))
1867 {
a48d60b1
MD		 1868 if (!*SCM_SUBR_GENERIC (subr))
1869 scm_enable_primitive_generic_x (scm_list_1 (subr));
1870 return *SCM_SUBR_GENERIC (subr);
80662eda 1871 }
db4b4ca6 1872 SCM_WRONG_TYPE_ARG (SCM_ARG1, subr);
80662eda 1873}
398d8ee1 1874#undef FUNC_NAME
80662eda 1875
a48d60b1
MD		 1876typedef struct t_extension {
1877 struct t_extension *next;
1878 SCM extended;
1879 SCM extension;
1880} t_extension;
1881
1882static t_extension *extensions = 0;
1883
1884SCM_VARIABLE (scm_var_make_extended_generic, "make-extended-generic");
1885
1886void
1887scm_c_extend_primitive_generic (SCM extended, SCM extension)
1888{
1889 if (goops_loaded_p)
1890 {
1891 SCM gf, gext;
1892 if (!*SCM_SUBR_GENERIC (extended))
1893 scm_enable_primitive_generic_x (scm_list_1 (extended));
1894 gf = *SCM_SUBR_GENERIC (extended);
1895 gext = scm_call_2 (SCM_VARIABLE_REF (scm_var_make_extended_generic),
1896 gf,
1897 SCM_SNAME (extension));
1898 *SCM_SUBR_GENERIC (extension) = gext;
1899 }
1900 else
1901 {
1902 t_extension *e = scm_malloc (sizeof (t_extension));
1903 t_extension **loc = &extensions;
1904 /* Make sure that extensions are placed before their own
1905 * extensions in the extensions list. O(N^2) algorithm, but
1906 * extensions of primitive generics are rare.
1907 */
1908 while (*loc && extension != (*loc)->extended)
1909 loc = &(*loc)->next;
1910 e->next = *loc;
1911 e->extended = extended;
1912 e->extension = extension;
1913 *loc = e;
1914 }
1915}
1916
1917static void
1918setup_extended_primitive_generics ()
1919{
1920 while (extensions)
1921 {
1922 t_extension *e = extensions;
1923 scm_c_extend_primitive_generic (e->extended, e->extension);
1924 extensions = e->next;
1925 free (e);
1926 }
1927}
1928
80662eda 1929/******************************************************************************
6d77c894 1930 *
80662eda 1931 * Protocol for calling a generic fumction
6d77c894 1932 * This protocol is roughly equivalent to (parameter are a little bit different
80662eda
MD		 1933 * for efficiency reasons):
1934 *
1935 * + apply-generic (gf args)
1936 * + compute-applicable-methods (gf args ...)
1937 * + sort-applicable-methods (methods args)
1938 * + apply-methods (gf methods args)
6d77c894
TTN		 1939 *
1940 * apply-methods calls make-next-method to build the "continuation" of a a
80662eda
MD		 1941 * method. Applying a next-method will call apply-next-method which in
1942 * turn will call apply again to call effectively the following method.
1943 *
1944 ******************************************************************************/
1945
1946static int
1947applicablep (SCM actual, SCM formal)
1948{
79a3dafe 1949 /* We already know that the cpl is well formed. */
7888309b 1950 return scm_is_true (scm_c_memq (formal, SCM_SLOT (actual, scm_si_cpl)));
80662eda
MD		 1951}
1952
1953static int
34d19ef6 1954more_specificp (SCM m1, SCM m2, SCM const *targs)
80662eda
MD		 1955{
1956 register SCM s1, s2;
c014a02e 1957 register long i;
6d77c894
TTN		 1958 /*
1959 * Note:
1960 * m1 and m2 can have != length (i.e. one can be one element longer than the
80662eda
MD		 1961 * other when we have a dotted parameter list). For instance, with the call
1962 * (M 1)
1963 * with
1964 * (define-method M (a . l) ....)
6d77c894 1965 * (define-method M (a) ....)
80662eda
MD		 1966 *
1967 * we consider that the second method is more specific.
1968 *
1969 * BTW, targs is an array of types. We don't need it's size since
1970 * we already know that m1 and m2 are applicable (no risk to go past
1971 * the end of this array).
1972 *
1973 */
34d19ef6 1974 for (i=0, s1=SPEC_OF(m1), s2=SPEC_OF(m2); ; i++, s1=SCM_CDR(s1), s2=SCM_CDR(s2)) {
d2e53ed6
MV		 1975 if (scm_is_null(s1)) return 1;
1976 if (scm_is_null(s2)) return 0;
80662eda
MD		 1977 if (SCM_CAR(s1) != SCM_CAR(s2)) {
1978 register SCM l, cs1 = SCM_CAR(s1), cs2 = SCM_CAR(s2);
6d77c894 1979
dcb410ec 1980 for (l = SCM_SLOT (targs[i], scm_si_cpl); ; l = SCM_CDR(l)) {
80662eda
MD		 1981 if (cs1 == SCM_CAR(l))
1982 return 1;
1983 if (cs2 == SCM_CAR(l))
1984 return 0;
1985 }
1986 return 0;/* should not occur! */
1987 }
1988 }
1989 return 0; /* should not occur! */
1990}
1991
1992#define BUFFSIZE 32 /* big enough for most uses */
1993
1994static SCM
c014a02e 1995scm_i_vector2list (SCM l, long len)
80662eda 1996{
c014a02e 1997 long j;
00ffa0e7 1998 SCM z = scm_c_make_vector (len, SCM_UNDEFINED);
6d77c894 1999
80662eda 2000 for (j = 0; j < len; j++, l = SCM_CDR (l)) {
4057a3e0 2001 SCM_SIMPLE_VECTOR_SET (z, j, SCM_CAR (l));
80662eda
MD		 2002 }
2003 return z;
2004}
2005
2006static SCM
34d19ef6 2007sort_applicable_methods (SCM method_list, long size, SCM const *targs)
80662eda 2008{
c014a02e 2009 long i, j, incr;
80662eda
MD		 2010 SCM *v, vector = SCM_EOL;
2011 SCM buffer[BUFFSIZE];
2012 SCM save = method_list;
4057a3e0 2013 scm_t_array_handle handle;
80662eda
MD		 2014
2015 /* For reasonably sized method_lists we can try to avoid all the
2016 * consing and reorder the list in place...
2017 * This idea is due to David McClain <Dave_McClain@msn.com>
2018 */
2019 if (size <= BUFFSIZE)
2020 {
2021 for (i = 0; i < size; i++)
2022 {
2023 buffer[i] = SCM_CAR (method_list);
2024 method_list = SCM_CDR (method_list);
2025 }
2026 v = buffer;
6d77c894 2027 }
80662eda
MD		 2028 else
2029 {
2030 /* Too many elements in method_list to keep everything locally */
2031 vector = scm_i_vector2list (save, size);
4057a3e0 2032 v = scm_vector_writable_elements (vector, &handle, NULL, NULL);
80662eda
MD		 2033 }
2034
6d77c894 2035 /* Use a simple shell sort since it is generally faster than qsort on
80662eda
MD		 2036 * small vectors (which is probably mostly the case when we have to
2037 * sort a list of applicable methods).
2038 */
2039 for (incr = size / 2; incr; incr /= 2)
2040 {
2041 for (i = incr; i < size; i++)
2042 {
2043 for (j = i - incr; j >= 0; j -= incr)
2044 {
2045 if (more_specificp (v[j], v[j+incr], targs))
2046 break;
2047 else
2048 {
2049 SCM tmp = v[j + incr];
2050 v[j + incr] = v[j];
2051 v[j] = tmp;
2052 }
2053 }
2054 }
2055 }
2056
2057 if (size <= BUFFSIZE)
2058 {
2059 /* We did it in locally, so restore the original list (reordered) in-place */
2060 for (i = 0, method_list = save; i < size; i++, v++)
2061 {
2062 SCM_SETCAR (method_list, *v);
2063 method_list = SCM_CDR (method_list);
2064 }
2065 return save;
2066 }
4057a3e0 2067
6d77c894 2068 /* If we are here, that's that we did it the hard way... */
c8857a4d 2069 scm_array_handle_release (&handle);
80662eda
MD		 2070 return scm_vector_to_list (vector);
2071}
2072
2073SCM
c014a02e 2074scm_compute_applicable_methods (SCM gf, SCM args, long len, int find_method_p)
80662eda 2075{
c014a02e
ML		 2076 register long i;
2077 long count = 0;
80662eda
MD		 2078 SCM l, fl, applicable = SCM_EOL;
2079 SCM save = args;
34d19ef6
HWN		 2080 SCM buffer[BUFFSIZE];
2081 SCM const *types;
2082 SCM *p;
2083 SCM tmp = SCM_EOL;
4057a3e0 2084 scm_t_array_handle handle;
6d77c894 2085
80662eda 2086 /* Build the list of arguments types */
4057a3e0
MV		 2087 if (len >= BUFFSIZE)
2088 {
2089 tmp = scm_c_make_vector (len, SCM_UNDEFINED);
2090 types = p = scm_vector_writable_elements (tmp, &handle, NULL, NULL);
34d19ef6
HWN		 2091
2092 /*
2093 note that we don't have to work to reset the generation
2094 count. TMP is a new vector anyway, and it is found
2095 conservatively.
2096 */
4057a3e0 2097 }
80662eda
MD		 2098 else
2099 types = p = buffer;
6d77c894 2100
d2e53ed6 2101 for ( ; !scm_is_null (args); args = SCM_CDR (args))
80662eda 2102 *p++ = scm_class_of (SCM_CAR (args));
34d19ef6 2103
80662eda 2104 /* Build a list of all applicable methods */
d2e53ed6 2105 for (l = scm_generic_function_methods (gf); !scm_is_null (l); l = SCM_CDR (l))
80662eda
MD		 2106 {
2107 fl = SPEC_OF (SCM_CAR (l));
2108 /* Only accept accessors which match exactly in first arg. */
2109 if (SCM_ACCESSORP (SCM_CAR (l))
d2e53ed6 2110 && (scm_is_null (fl) || types[0] != SCM_CAR (fl)))
80662eda
MD		 2111 continue;
2112 for (i = 0; ; i++, fl = SCM_CDR (fl))
2113 {
c312aca7 2114 if (SCM_INSTANCEP (fl)
80662eda 2115 /* We have a dotted argument list */
d2e53ed6 2116 || (i >= len && scm_is_null (fl)))
80662eda
MD		 2117 { /* both list exhausted */
2118 applicable = scm_cons (SCM_CAR (l), applicable);
2119 count += 1;
2120 break;
2121 }
2122 if (i >= len
d2e53ed6 2123 || scm_is_null (fl)
80662eda
MD		 2124 || !applicablep (types[i], SCM_CAR (fl)))
2125 break;
2126 }
2127 }
2128
c8857a4d
MV		 2129 if (len >= BUFFSIZE)
2130 scm_array_handle_release (&handle);
2131
80662eda
MD		 2132 if (count == 0)
2133 {
2134 if (find_method_p)
2135 return SCM_BOOL_F;
2136 CALL_GF2 ("no-applicable-method", gf, save);
2137 /* if we are here, it's because no-applicable-method hasn't signaled an error */
2138 return SCM_BOOL_F;
2139 }
34d19ef6 2140
80662eda
MD		 2141 return (count == 1
2142 ? applicable
2143 : sort_applicable_methods (applicable, count, types));
2144}
2145
2146#if 0
2147SCM_PROC (s_sys_compute_applicable_methods, "%compute-applicable-methods", 2, 0, 0, scm_sys_compute_applicable_methods);
2148#endif
2149
2150static const char s_sys_compute_applicable_methods[] = "%compute-applicable-methods";
2151
2152SCM
2153scm_sys_compute_applicable_methods (SCM gf, SCM args)
398d8ee1 2154#define FUNC_NAME s_sys_compute_applicable_methods
80662eda 2155{
c014a02e 2156 long n;
398d8ee1 2157 SCM_VALIDATE_GENERIC (1, gf);
80662eda 2158 n = scm_ilength (args);
398d8ee1 2159 SCM_ASSERT (n >= 0, args, SCM_ARG2, FUNC_NAME);
80662eda
MD		 2160 return scm_compute_applicable_methods (gf, args, n, 1);
2161}
398d8ee1 2162#undef FUNC_NAME
80662eda 2163
86d31dfe 2164SCM_SYMBOL (sym_compute_applicable_methods, "compute-applicable-methods");
9a441ddb 2165SCM_VARIABLE_INIT (var_compute_applicable_methods, "compute-applicable-methods", scm_c_define_gsubr (s_sys_compute_applicable_methods, 2, 0, 0, scm_sys_compute_applicable_methods));
80662eda 2166
80662eda
MD		 2167static void
2168lock_cache_mutex (void *m)
2169{
6b80d352 2170 SCM mutex = SCM_PACK ((scm_t_bits) m);
80662eda
MD		 2171 scm_lock_mutex (mutex);
2172}
2173
2174static void
2175unlock_cache_mutex (void *m)
2176{
6b80d352 2177 SCM mutex = SCM_PACK ((scm_t_bits) m);
80662eda
MD		 2178 scm_unlock_mutex (mutex);
2179}
80662eda
MD		 2180
2181static SCM
2182call_memoize_method (void *a)
2183{
6b80d352 2184 SCM args = SCM_PACK ((scm_t_bits) a);
80662eda
MD		 2185 SCM gf = SCM_CAR (args);
2186 SCM x = SCM_CADR (args);
2187 /* First check if another thread has inserted a method between
2188 * the cache miss and locking the mutex.
2189 */
2190 SCM cmethod = scm_mcache_lookup_cmethod (x, SCM_CDDR (args));
7888309b 2191 if (scm_is_true (cmethod))
80662eda
MD		 2192 return cmethod;
2193 /*fixme* Use scm_apply */
2194 return CALL_GF3 ("memoize-method!", gf, SCM_CDDR (args), x);
2195}
2196
2197SCM
2198scm_memoize_method (SCM x, SCM args)
2199{
2200 SCM gf = SCM_CAR (scm_last_pair (x));
6b80d352
DH		 2201 return scm_internal_dynamic_wind (
2202 lock_cache_mutex,
2203 call_memoize_method,
2204 unlock_cache_mutex,
2205 (void *) SCM_UNPACK (scm_cons2 (gf, x, args)),
2206 (void *) SCM_UNPACK (SCM_SLOT (gf, scm_si_cache_mutex)));
80662eda
MD		 2207}
2208
2209/******************************************************************************
2210 *
2211 * A simple make (which will be redefined later in Scheme)
2212 * This version handles only creation of gf, methods and classes (no instances)
2213 *
6d77c894 2214 * Since this code will disappear when Goops will be fully booted,
80662eda
MD		 2215 * no precaution is taken to be efficient.
2216 *
2217 ******************************************************************************/
2218
2219SCM_KEYWORD (k_setter, "setter");
2220SCM_KEYWORD (k_specializers, "specializers");
2221SCM_KEYWORD (k_procedure, "procedure");
2222SCM_KEYWORD (k_dsupers, "dsupers");
2223SCM_KEYWORD (k_slots, "slots");
2224SCM_KEYWORD (k_gf, "generic-function");
2225
398d8ee1
KN		 2226SCM_DEFINE (scm_make, "make", 0, 0, 1,
2227 (SCM args),
27c37006 2228 "Make a new object. @var{args} must contain the class and\n"
6bcefd15 2229 "all necessary initialization information.")
398d8ee1 2230#define FUNC_NAME s_scm_make
80662eda
MD		 2231{
2232 SCM class, z;
c014a02e 2233 long len = scm_ilength (args);
80662eda
MD		 2234
2235 if (len <= 0 || (len & 1) == 0)
398d8ee1 2236 SCM_WRONG_NUM_ARGS ();
80662eda
MD		 2237
2238 class = SCM_CAR(args);
2239 args = SCM_CDR(args);
2240
f8af5c6d 2241 if (class == scm_class_generic || class == scm_class_accessor)
80662eda 2242 {
80662eda 2243 z = scm_make_struct (class, SCM_INUM0,
bbf8d523 2244 scm_list_5 (SCM_EOL,
1afff620
KN		 2245 SCM_INUM0,
2246 SCM_BOOL_F,
bbf8d523
MD		 2247 scm_make_mutex (),
2248 SCM_EOL));
80662eda
MD		 2249 scm_set_procedure_property_x (z, scm_sym_name,
2250 scm_get_keyword (k_name,
2251 args,
2252 SCM_BOOL_F));
2253 clear_method_cache (z);
f8af5c6d 2254 if (class == scm_class_accessor)
80662eda
MD		 2255 {
2256 SCM setter = scm_get_keyword (k_setter, args, SCM_BOOL_F);
7888309b 2257 if (scm_is_true (setter))
80662eda
MD		 2258 scm_sys_set_object_setter_x (z, setter);
2259 }
2260 }
2261 else
2262 {
2263 z = scm_sys_allocate_instance (class, args);
2264
2265 if (class == scm_class_method
2266 || class == scm_class_simple_method
f8af5c6d 2267 || class == scm_class_accessor_method)
80662eda 2268 {
6d77c894 2269 SCM_SET_SLOT (z, scm_si_generic_function,
80662eda
MD		 2270 scm_i_get_keyword (k_gf,
2271 args,
2272 len - 1,
2273 SCM_BOOL_F,
dcb410ec 2274 FUNC_NAME));
6d77c894 2275 SCM_SET_SLOT (z, scm_si_specializers,
80662eda
MD		 2276 scm_i_get_keyword (k_specializers,
2277 args,
2278 len - 1,
2279 SCM_EOL,
dcb410ec 2280 FUNC_NAME));
6d77c894 2281 SCM_SET_SLOT (z, scm_si_procedure,
80662eda
MD		 2282 scm_i_get_keyword (k_procedure,
2283 args,
2284 len - 1,
2285 SCM_EOL,
dcb410ec
DH		 2286 FUNC_NAME));
2287 SCM_SET_SLOT (z, scm_si_code_table, SCM_EOL);
80662eda
MD		 2288 }
2289 else
2290 {
2291 /* In all the others case, make a new class .... No instance here */
6d77c894 2292 SCM_SET_SLOT (z, scm_si_name,
80662eda
MD		 2293 scm_i_get_keyword (k_name,
2294 args,
2295 len - 1,
cc95e00a 2296 scm_from_locale_symbol ("???"),
dcb410ec 2297 FUNC_NAME));
6d77c894 2298 SCM_SET_SLOT (z, scm_si_direct_supers,
80662eda
MD		 2299 scm_i_get_keyword (k_dsupers,
2300 args,
2301 len - 1,
2302 SCM_EOL,
dcb410ec 2303 FUNC_NAME));
6d77c894 2304 SCM_SET_SLOT (z, scm_si_direct_slots,
80662eda
MD		 2305 scm_i_get_keyword (k_slots,
2306 args,
2307 len - 1,
2308 SCM_EOL,
dcb410ec 2309 FUNC_NAME));
80662eda
MD		 2310 }
2311 }
2312 return z;
2313}
398d8ee1 2314#undef FUNC_NAME
80662eda 2315
398d8ee1
KN		 2316SCM_DEFINE (scm_find_method, "find-method", 0, 0, 1,
2317 (SCM l),
2318 "")
2319#define FUNC_NAME s_scm_find_method
80662eda
MD		 2320{
2321 SCM gf;
c014a02e 2322 long len = scm_ilength (l);
80662eda
MD		 2323
2324 if (len == 0)
398d8ee1 2325 SCM_WRONG_NUM_ARGS ();
80662eda
MD		 2326
2327 gf = SCM_CAR(l); l = SCM_CDR(l);
398d8ee1 2328 SCM_VALIDATE_GENERIC (1, gf);
d2e53ed6 2329 if (scm_is_null (SCM_SLOT (gf, scm_si_methods)))
1afff620 2330 SCM_MISC_ERROR ("no methods for generic ~S", scm_list_1 (gf));
80662eda
MD		 2331
2332 return scm_compute_applicable_methods (gf, l, len - 1, 1);
2333}
398d8ee1 2334#undef FUNC_NAME
80662eda 2335
398d8ee1
KN		 2336SCM_DEFINE (scm_sys_method_more_specific_p, "%method-more-specific?", 3, 0, 0,
2337 (SCM m1, SCM m2, SCM targs),
b1f57ea4
LC		 2338 "Return true if method @var{m1} is more specific than @var{m2} "
2339 "given the argument types (classes) listed in @var{targs}.")
398d8ee1 2340#define FUNC_NAME s_scm_sys_method_more_specific_p
80662eda 2341{
4057a3e0
MV		 2342 SCM l, v, result;
2343 SCM *v_elts;
b1f57ea4 2344 long i, len, m1_specs, m2_specs;
4057a3e0 2345 scm_t_array_handle handle;
80662eda 2346
398d8ee1
KN		 2347 SCM_VALIDATE_METHOD (1, m1);
2348 SCM_VALIDATE_METHOD (2, m2);
80662eda 2349
b1f57ea4
LC		 2350 len = scm_ilength (targs);
2351 m1_specs = scm_ilength (SPEC_OF (m1));
2352 m2_specs = scm_ilength (SPEC_OF (m2));
2353 SCM_ASSERT ((len >= m1_specs) || (len >= m2_specs),
2354 targs, SCM_ARG3, FUNC_NAME);
2355
2356 /* Verify that all the arguments of TARGS are classes and place them
2357 in a vector. */
4057a3e0 2358
00ffa0e7 2359 v = scm_c_make_vector (len, SCM_EOL);
4057a3e0 2360 v_elts = scm_vector_writable_elements (v, &handle, NULL, NULL);
80662eda 2361
b1f57ea4
LC		 2362 for (i = 0, l = targs;
2363 i < len && scm_is_pair (l);
2364 i++, l = SCM_CDR (l))
4057a3e0
MV		 2365 {
2366 SCM_ASSERT (SCM_CLASSP (SCM_CAR (l)), targs, SCM_ARG3, FUNC_NAME);
b1f57ea4 2367 v_elts[i] = SCM_CAR (l);
4057a3e0 2368 }
4057a3e0 2369 result = more_specificp (m1, m2, v_elts) ? SCM_BOOL_T: SCM_BOOL_F;
c8857a4d
MV		 2370
2371 scm_array_handle_release (&handle);
2372
4057a3e0 2373 return result;
80662eda 2374}
398d8ee1 2375#undef FUNC_NAME
6d77c894
TTN		 2376
2377
80662eda
MD		 2378
2379/******************************************************************************
2380 *
6d77c894 2381 * Initializations
80662eda
MD		 2382 *
2383 ******************************************************************************/
2384
74b6d6e4
MD		 2385static void
2386fix_cpl (SCM c, SCM before, SCM after)
2387{
2388 SCM cpl = SCM_SLOT (c, scm_si_cpl);
2389 SCM ls = scm_c_memq (after, cpl);
2390 SCM tail = scm_delq1_x (before, SCM_CDR (ls));
7888309b 2391 if (scm_is_false (ls))
74b6d6e4
MD		 2392 /* if this condition occurs, fix_cpl should not be applied this way */
2393 abort ();
2394 SCM_SETCAR (ls, before);
2395 SCM_SETCDR (ls, scm_cons (after, tail));
2396 {
2397 SCM dslots = SCM_SLOT (c, scm_si_direct_slots);
2398 SCM slots = build_slots_list (maplist (dslots), cpl);
2399 SCM g_n_s = compute_getters_n_setters (slots);
2400 SCM_SET_SLOT (c, scm_si_slots, slots);
2401 SCM_SET_SLOT (c, scm_si_getters_n_setters, g_n_s);
2402 }
2403}
2404
80662eda
MD		 2405
2406static void
2407make_stdcls (SCM *var, char *name, SCM meta, SCM super, SCM slots)
2408{
cc95e00a 2409 SCM tmp = scm_from_locale_symbol (name);
6d77c894 2410
80662eda
MD		 2411 *var = scm_permanent_object (scm_basic_make_class (meta,
2412 tmp,
d2e53ed6 2413 scm_is_pair (super)
80662eda 2414 ? super
1afff620 2415 : scm_list_1 (super),
80662eda
MD		 2416 slots));
2417 DEFVAR(tmp, *var);
2418}
2419
2420
2421SCM_KEYWORD (k_slot_definition, "slot-definition");
2422
2423static void
2424create_standard_classes (void)
2425{
2426 SCM slots;
cc95e00a
MV		 2427 SCM method_slots = scm_list_4 (scm_from_locale_symbol ("generic-function"),
2428 scm_from_locale_symbol ("specializers"),
6b80d352 2429 sym_procedure,
cc95e00a
MV		 2430 scm_from_locale_symbol ("code-table"));
2431 SCM amethod_slots = scm_list_1 (scm_list_3 (scm_from_locale_symbol ("slot-definition"),
1afff620
KN		 2432 k_init_keyword,
2433 k_slot_definition));
cc95e00a 2434 SCM mutex_slot = scm_list_1 (scm_from_locale_symbol ("make-mutex"));
366ecaec
DH		 2435 SCM mutex_closure = scm_i_eval_x (scm_list_3 (scm_sym_lambda,
2436 SCM_EOL,
2437 mutex_slot),
2438 SCM_EOL);
cc95e00a
MV		 2439 SCM gf_slots = scm_list_5 (scm_from_locale_symbol ("methods"),
2440 scm_list_3 (scm_from_locale_symbol ("n-specialized"),
1afff620
KN		 2441 k_init_value,
2442 SCM_INUM0),
cc95e00a 2443 scm_list_3 (scm_from_locale_symbol ("used-by"),
1afff620
KN		 2444 k_init_value,
2445 SCM_BOOL_F),
cc95e00a 2446 scm_list_3 (scm_from_locale_symbol ("cache-mutex"),
1afff620 2447 k_init_thunk,
366ecaec 2448 mutex_closure),
cc95e00a 2449 scm_list_3 (scm_from_locale_symbol ("extended-by"),
bbf8d523
MD		 2450 k_init_value,
2451 SCM_EOL));
cc95e00a 2452 SCM egf_slots = scm_list_1 (scm_list_3 (scm_from_locale_symbol ("extends"),
bbf8d523
MD		 2453 k_init_value,
2454 SCM_EOL));
80662eda
MD		 2455 /* Foreign class slot classes */
2456 make_stdcls (&scm_class_foreign_slot, "<foreign-slot>",
2457 scm_class_class, scm_class_top, SCM_EOL);
2458 make_stdcls (&scm_class_protected, "<protected-slot>",
2459 scm_class_class, scm_class_foreign_slot, SCM_EOL);
2460 make_stdcls (&scm_class_opaque, "<opaque-slot>",
2461 scm_class_class, scm_class_foreign_slot, SCM_EOL);
2462 make_stdcls (&scm_class_read_only, "<read-only-slot>",
2463 scm_class_class, scm_class_foreign_slot, SCM_EOL);
2464 make_stdcls (&scm_class_self, "<self-slot>",
2465 scm_class_class,
74b6d6e4 2466 scm_class_read_only,
80662eda
MD		 2467 SCM_EOL);
2468 make_stdcls (&scm_class_protected_opaque, "<protected-opaque-slot>",
2469 scm_class_class,
1afff620 2470 scm_list_2 (scm_class_protected, scm_class_opaque),
80662eda
MD		 2471 SCM_EOL);
2472 make_stdcls (&scm_class_protected_read_only, "<protected-read-only-slot>",
2473 scm_class_class,
1afff620 2474 scm_list_2 (scm_class_protected, scm_class_read_only),
80662eda
MD		 2475 SCM_EOL);
2476 make_stdcls (&scm_class_scm, "<scm-slot>",
2477 scm_class_class, scm_class_protected, SCM_EOL);
2478 make_stdcls (&scm_class_int, "<int-slot>",
2479 scm_class_class, scm_class_foreign_slot, SCM_EOL);
2480 make_stdcls (&scm_class_float, "<float-slot>",
2481 scm_class_class, scm_class_foreign_slot, SCM_EOL);
2482 make_stdcls (&scm_class_double, "<double-slot>",
2483 scm_class_class, scm_class_foreign_slot, SCM_EOL);
2484
2485 /* Continue initialization of class <class> */
6d77c894 2486
80662eda 2487 slots = build_class_class_slots ();
dcb410ec
DH		 2488 SCM_SET_SLOT (scm_class_class, scm_si_direct_slots, slots);
2489 SCM_SET_SLOT (scm_class_class, scm_si_slots, slots);
2490 SCM_SET_SLOT (scm_class_class, scm_si_getters_n_setters,
2491 compute_getters_n_setters (slots));
6d77c894 2492
80662eda
MD		 2493 make_stdcls (&scm_class_foreign_class, "<foreign-class>",
2494 scm_class_class, scm_class_class,
cc95e00a 2495 scm_list_2 (scm_list_3 (scm_from_locale_symbol ("constructor"),
1afff620
KN		 2496 k_class,
2497 scm_class_opaque),
cc95e00a 2498 scm_list_3 (scm_from_locale_symbol ("destructor"),
1afff620
KN		 2499 k_class,
2500 scm_class_opaque)));
80662eda
MD		 2501 make_stdcls (&scm_class_foreign_object, "<foreign-object>",
2502 scm_class_foreign_class, scm_class_object, SCM_EOL);
2503 SCM_SET_CLASS_FLAGS (scm_class_foreign_object, SCM_CLASSF_FOREIGN);
2504
2505 /* scm_class_generic functions classes */
2506 make_stdcls (&scm_class_procedure_class, "<procedure-class>",
2507 scm_class_class, scm_class_class, SCM_EOL);
2508 make_stdcls (&scm_class_entity_class, "<entity-class>",
2509 scm_class_class, scm_class_procedure_class, SCM_EOL);
2510 make_stdcls (&scm_class_operator_class, "<operator-class>",
2511 scm_class_class, scm_class_procedure_class, SCM_EOL);
2512 make_stdcls (&scm_class_operator_with_setter_class,
2513 "<operator-with-setter-class>",
2514 scm_class_class, scm_class_operator_class, SCM_EOL);
2515 make_stdcls (&scm_class_method, "<method>",
2516 scm_class_class, scm_class_object, method_slots);
2517 make_stdcls (&scm_class_simple_method, "<simple-method>",
2518 scm_class_class, scm_class_method, SCM_EOL);
2519 SCM_SET_CLASS_FLAGS (scm_class_simple_method, SCM_CLASSF_SIMPLE_METHOD);
f8af5c6d 2520 make_stdcls (&scm_class_accessor_method, "<accessor-method>",
80662eda 2521 scm_class_class, scm_class_simple_method, amethod_slots);
f8af5c6d 2522 SCM_SET_CLASS_FLAGS (scm_class_accessor_method, SCM_CLASSF_ACCESSOR_METHOD);
74b6d6e4
MD		 2523 make_stdcls (&scm_class_applicable, "<applicable>",
2524 scm_class_class, scm_class_top, SCM_EOL);
80662eda 2525 make_stdcls (&scm_class_entity, "<entity>",
74b6d6e4
MD		 2526 scm_class_entity_class,
2527 scm_list_2 (scm_class_object, scm_class_applicable),
2528 SCM_EOL);
80662eda
MD		 2529 make_stdcls (&scm_class_entity_with_setter, "<entity-with-setter>",
2530 scm_class_entity_class, scm_class_entity, SCM_EOL);
2531 make_stdcls (&scm_class_generic, "<generic>",
2532 scm_class_entity_class, scm_class_entity, gf_slots);
2533 SCM_SET_CLASS_FLAGS (scm_class_generic, SCM_CLASSF_PURE_GENERIC);
bbf8d523 2534 make_stdcls (&scm_class_extended_generic, "<extended-generic>",
f8af5c6d 2535 scm_class_entity_class, scm_class_generic, egf_slots);
bbf8d523 2536 SCM_SET_CLASS_FLAGS (scm_class_extended_generic, SCM_CLASSF_PURE_GENERIC);
80662eda
MD		 2537 make_stdcls (&scm_class_generic_with_setter, "<generic-with-setter>",
2538 scm_class_entity_class,
1afff620 2539 scm_list_2 (scm_class_generic, scm_class_entity_with_setter),
80662eda 2540 SCM_EOL);
80662eda 2541 SCM_SET_CLASS_FLAGS (scm_class_generic_with_setter, SCM_CLASSF_PURE_GENERIC);
f8af5c6d
MD		 2542 make_stdcls (&scm_class_accessor, "<accessor>",
2543 scm_class_entity_class, scm_class_generic_with_setter, SCM_EOL);
2544 SCM_SET_CLASS_FLAGS (scm_class_accessor, SCM_CLASSF_PURE_GENERIC);
bbf8d523
MD		 2545 make_stdcls (&scm_class_extended_generic_with_setter,
2546 "<extended-generic-with-setter>",
2547 scm_class_entity_class,
74b6d6e4
MD		 2548 scm_list_2 (scm_class_generic_with_setter,
2549 scm_class_extended_generic),
bbf8d523
MD		 2550 SCM_EOL);
2551 SCM_SET_CLASS_FLAGS (scm_class_extended_generic_with_setter,
2552 SCM_CLASSF_PURE_GENERIC);
74b6d6e4
MD		 2553 make_stdcls (&scm_class_extended_accessor, "<extended-accessor>",
2554 scm_class_entity_class,
2555 scm_list_2 (scm_class_accessor,
2556 scm_class_extended_generic_with_setter),
2557 SCM_EOL);
2558 fix_cpl (scm_class_extended_accessor,
2559 scm_class_extended_generic, scm_class_generic);
2560 SCM_SET_CLASS_FLAGS (scm_class_extended_accessor, SCM_CLASSF_PURE_GENERIC);
80662eda
MD		 2561
2562 /* Primitive types classes */
2563 make_stdcls (&scm_class_boolean, "<boolean>",
2564 scm_class_class, scm_class_top, SCM_EOL);
2565 make_stdcls (&scm_class_char, "<char>",
2566 scm_class_class, scm_class_top, SCM_EOL);
2567 make_stdcls (&scm_class_list, "<list>",
2568 scm_class_class, scm_class_top, SCM_EOL);
2569 make_stdcls (&scm_class_pair, "<pair>",
2570 scm_class_class, scm_class_list, SCM_EOL);
2571 make_stdcls (&scm_class_null, "<null>",
2572 scm_class_class, scm_class_list, SCM_EOL);
2573 make_stdcls (&scm_class_string, "<string>",
2574 scm_class_class, scm_class_top, SCM_EOL);
2575 make_stdcls (&scm_class_symbol, "<symbol>",
2576 scm_class_class, scm_class_top, SCM_EOL);
2577 make_stdcls (&scm_class_vector, "<vector>",
2578 scm_class_class, scm_class_top, SCM_EOL);
2579 make_stdcls (&scm_class_number, "<number>",
2580 scm_class_class, scm_class_top, SCM_EOL);
2581 make_stdcls (&scm_class_complex, "<complex>",
2582 scm_class_class, scm_class_number, SCM_EOL);
2583 make_stdcls (&scm_class_real, "<real>",
2584 scm_class_class, scm_class_complex, SCM_EOL);
2585 make_stdcls (&scm_class_integer, "<integer>",
2586 scm_class_class, scm_class_real, SCM_EOL);
f92e85f7
MV		 2587 make_stdcls (&scm_class_fraction, "<fraction>",
2588 scm_class_class, scm_class_real, SCM_EOL);
80662eda
MD		 2589 make_stdcls (&scm_class_keyword, "<keyword>",
2590 scm_class_class, scm_class_top, SCM_EOL);
2591 make_stdcls (&scm_class_unknown, "<unknown>",
2592 scm_class_class, scm_class_top, SCM_EOL);
2593 make_stdcls (&scm_class_procedure, "<procedure>",
74b6d6e4 2594 scm_class_procedure_class, scm_class_applicable, SCM_EOL);
80662eda
MD		 2595 make_stdcls (&scm_class_procedure_with_setter, "<procedure-with-setter>",
2596 scm_class_procedure_class, scm_class_procedure, SCM_EOL);
2597 make_stdcls (&scm_class_primitive_generic, "<primitive-generic>",
2598 scm_class_procedure_class, scm_class_procedure, SCM_EOL);
2599 make_stdcls (&scm_class_port, "<port>",
2600 scm_class_class, scm_class_top, SCM_EOL);
2601 make_stdcls (&scm_class_input_port, "<input-port>",
2602 scm_class_class, scm_class_port, SCM_EOL);
2603 make_stdcls (&scm_class_output_port, "<output-port>",
2604 scm_class_class, scm_class_port, SCM_EOL);
2605 make_stdcls (&scm_class_input_output_port, "<input-output-port>",
2606 scm_class_class,
1afff620 2607 scm_list_2 (scm_class_input_port, scm_class_output_port),
80662eda
MD		 2608 SCM_EOL);
2609}
2610
2611/**********************************************************************
2612 *
2613 * Smob classes
2614 *
2615 **********************************************************************/
2616
2617static SCM
da0e6c2b 2618make_class_from_template (char const *template, char const *type_name, SCM supers, int applicablep)
80662eda
MD		 2619{
2620 SCM class, name;
2621 if (type_name)
2622 {
2623 char buffer[100];
2624 sprintf (buffer, template, type_name);
cc95e00a 2625 name = scm_from_locale_symbol (buffer);
80662eda
MD		 2626 }
2627 else
2628 name = SCM_GOOPS_UNBOUND;
2629
74b6d6e4
MD		 2630 class = scm_permanent_object (scm_basic_make_class (applicablep
2631 ? scm_class_procedure_class
2632 : scm_class_class,
80662eda
MD		 2633 name,
2634 supers,
2635 SCM_EOL));
2636
2637 /* Only define name if doesn't already exist. */
2638 if (!SCM_GOOPS_UNBOUNDP (name)
7888309b 2639 && scm_is_false (scm_call_2 (scm_goops_lookup_closure, name, SCM_BOOL_F)))
0ba8a0a5 2640 DEFVAR (name, class);
80662eda
MD		 2641 return class;
2642}
2643
2644SCM
da0e6c2b 2645scm_make_extended_class (char const *type_name, int applicablep)
80662eda
MD		 2646{
2647 return make_class_from_template ("<%s>",
2648 type_name,
74b6d6e4
MD		 2649 scm_list_1 (applicablep
2650 ? scm_class_applicable
2651 : scm_class_top),
2652 applicablep);
2653}
2654
2655void
2656scm_i_inherit_applicable (SCM c)
2657{
2658 if (!SCM_SUBCLASSP (c, scm_class_applicable))
2659 {
2660 SCM dsupers = SCM_SLOT (c, scm_si_direct_supers);
2661 SCM cpl = SCM_SLOT (c, scm_si_cpl);
2662 /* patch scm_class_applicable into direct-supers */
2663 SCM top = scm_c_memq (scm_class_top, dsupers);
7888309b 2664 if (scm_is_false (top))
74b6d6e4
MD		 2665 dsupers = scm_append (scm_list_2 (dsupers,
2666 scm_list_1 (scm_class_applicable)));
2667 else
2668 {
2669 SCM_SETCAR (top, scm_class_applicable);
2670 SCM_SETCDR (top, scm_cons (scm_class_top, SCM_CDR (top)));
2671 }
2672 SCM_SET_SLOT (c, scm_si_direct_supers, dsupers);
2673 /* patch scm_class_applicable into cpl */
2674 top = scm_c_memq (scm_class_top, cpl);
7888309b 2675 if (scm_is_false (top))
74b6d6e4
MD		 2676 abort ();
2677 else
2678 {
2679 SCM_SETCAR (top, scm_class_applicable);
2680 SCM_SETCDR (top, scm_cons (scm_class_top, SCM_CDR (top)));
2681 }
2682 /* add class to direct-subclasses of scm_class_applicable */
2683 SCM_SET_SLOT (scm_class_applicable,
2684 scm_si_direct_subclasses,
2685 scm_cons (c, SCM_SLOT (scm_class_applicable,
2686 scm_si_direct_subclasses)));
2687 }
80662eda
MD		 2688}
2689
2690static void
2691create_smob_classes (void)
2692{
c014a02e 2693 long i;
80662eda 2694
67329a9e 2695 scm_smob_class = (SCM *) scm_malloc (255 * sizeof (SCM));
80662eda
MD		 2696 for (i = 0; i < 255; ++i)
2697 scm_smob_class[i] = 0;
2698
80662eda 2699 scm_smob_class[SCM_TC2SMOBNUM (scm_tc16_keyword)] = scm_class_keyword;
6d77c894 2700
80662eda
MD		 2701 for (i = 0; i < scm_numsmob; ++i)
2702 if (!scm_smob_class[i])
74b6d6e4
MD		 2703 scm_smob_class[i] = scm_make_extended_class (SCM_SMOBNAME (i),
2704 scm_smobs[i].apply != 0);
80662eda
MD		 2705}
2706
2707void
c014a02e 2708scm_make_port_classes (long ptobnum, char *type_name)
80662eda
MD		 2709{
2710 SCM c, class = make_class_from_template ("<%s-port>",
2711 type_name,
74b6d6e4
MD		 2712 scm_list_1 (scm_class_port),
2713 0);
80662eda
MD		 2714 scm_port_class[SCM_IN_PCLASS_INDEX + ptobnum]
2715 = make_class_from_template ("<%s-input-port>",
2716 type_name,
74b6d6e4
MD		 2717 scm_list_2 (class, scm_class_input_port),
2718 0);
80662eda
MD		 2719 scm_port_class[SCM_OUT_PCLASS_INDEX + ptobnum]
2720 = make_class_from_template ("<%s-output-port>",
2721 type_name,
74b6d6e4
MD		 2722 scm_list_2 (class, scm_class_output_port),
2723 0);
80662eda
MD		 2724 scm_port_class[SCM_INOUT_PCLASS_INDEX + ptobnum]
2725 = c
2726 = make_class_from_template ("<%s-input-output-port>",
2727 type_name,
74b6d6e4
MD		 2728 scm_list_2 (class, scm_class_input_output_port),
2729 0);
80662eda 2730 /* Patch cpl (since this tree is too complex for the C level compute-cpl) */
dcb410ec
DH		 2731 SCM_SET_SLOT (c, scm_si_cpl,
2732 scm_cons2 (c, class, SCM_SLOT (scm_class_input_output_port, scm_si_cpl)));
80662eda
MD		 2733}
2734
2735static void
2736create_port_classes (void)
2737{
c014a02e 2738 long i;
80662eda 2739
67329a9e 2740 scm_port_class = (SCM *) scm_malloc (3 * 256 * sizeof (SCM));
80662eda
MD		 2741 for (i = 0; i < 3 * 256; ++i)
2742 scm_port_class[i] = 0;
2743
2744 for (i = 0; i < scm_numptob; ++i)
2745 scm_make_port_classes (i, SCM_PTOBNAME (i));
2746}
2747
2748static SCM
74b6d6e4
MD		 2749make_struct_class (void *closure SCM_UNUSED,
2750 SCM vtable, SCM data, SCM prev SCM_UNUSED)
80662eda 2751{
7888309b 2752 if (scm_is_true (SCM_STRUCT_TABLE_NAME (data)))
80662eda
MD		 2753 SCM_SET_STRUCT_TABLE_CLASS (data,
2754 scm_make_extended_class
cc95e00a 2755 (scm_i_symbol_chars (SCM_STRUCT_TABLE_NAME (data)),
74b6d6e4 2756 SCM_CLASS_FLAGS (vtable) & SCM_CLASSF_OPERATOR));
80662eda
MD		 2757 return SCM_UNSPECIFIED;
2758}
2759
2760static void
2761create_struct_classes (void)
2762{
2763 scm_internal_hash_fold (make_struct_class, 0, SCM_BOOL_F, scm_struct_table);
2764}
2765
2766/**********************************************************************
2767 *
2768 * C interface
2769 *
2770 **********************************************************************/
2771
2772void
2773scm_load_goops ()
2774{
2775 if (!goops_loaded_p)
abd28220 2776 scm_c_resolve_module ("oop goops");
80662eda
MD		 2777}
2778
e11208ca 2779
80662eda
MD		 2780SCM
2781scm_make_foreign_object (SCM class, SCM initargs)
e11208ca 2782#define FUNC_NAME s_scm_make
80662eda
MD		 2783{
2784 void * (*constructor) (SCM)
2785 = (void * (*) (SCM)) SCM_SLOT (class, scm_si_constructor);
e11208ca 2786 if (constructor == 0)
1afff620 2787 SCM_MISC_ERROR ("Can't make instances of class ~S", scm_list_1 (class));
80662eda
MD		 2788 return scm_wrap_object (class, constructor (initargs));
2789}
e11208ca
DH		 2790#undef FUNC_NAME
2791
80662eda
MD		 2792
2793static size_t
2794scm_free_foreign_object (SCM *class, SCM *data)
2795{
2796 size_t (*destructor) (void *)
2797 = (size_t (*) (void *)) class[scm_si_destructor];
2798 return destructor (data);
2799}
2800
2801SCM
2802scm_make_class (SCM meta, char *s_name, SCM supers, size_t size,
2803 void * (*constructor) (SCM initargs),
2804 size_t (*destructor) (void *))
2805{
2806 SCM name, class;
cc95e00a 2807 name = scm_from_locale_symbol (s_name);
d2e53ed6 2808 if (scm_is_null (supers))
1afff620 2809 supers = scm_list_1 (scm_class_foreign_object);
80662eda
MD		 2810 class = scm_basic_basic_make_class (meta, name, supers, SCM_EOL);
2811 scm_sys_inherit_magic_x (class, supers);
2812
2813 if (destructor != 0)
2814 {
dcb410ec 2815 SCM_SET_SLOT (class, scm_si_destructor, (SCM) destructor);
80662eda
MD		 2816 SCM_SET_CLASS_DESTRUCTOR (class, scm_free_foreign_object);
2817 }
2818 else if (size > 0)
2819 {
80662eda
MD		 2820 SCM_SET_CLASS_INSTANCE_SIZE (class, size);
2821 }
6d77c894 2822
cc95e00a 2823 SCM_SET_SLOT (class, scm_si_layout, scm_from_locale_symbol (""));
dcb410ec 2824 SCM_SET_SLOT (class, scm_si_constructor, (SCM) constructor);
80662eda
MD		 2825
2826 return class;
2827}
2828
2829SCM_SYMBOL (sym_o, "o");
2830SCM_SYMBOL (sym_x, "x");
2831
2832SCM_KEYWORD (k_accessor, "accessor");
2833SCM_KEYWORD (k_getter, "getter");
2834
2835static SCM
e81d98ec 2836default_setter (SCM obj SCM_UNUSED, SCM c SCM_UNUSED)
80662eda
MD		 2837{
2838 scm_misc_error ("slot-set!", "read-only slot", SCM_EOL);
2839 return 0;
2840}
2841
2842void
2843scm_add_slot (SCM class, char *slot_name, SCM slot_class,
2844 SCM (*getter) (SCM obj),
2845 SCM (*setter) (SCM obj, SCM x),
2846 char *accessor_name)
2847{
2848 {
9a441ddb
MV		 2849 SCM get = scm_c_make_subr ("goops:get", scm_tc7_subr_1, getter);
2850 SCM set = scm_c_make_subr ("goops:set", scm_tc7_subr_2,
2851 setter ? setter : default_setter);
366ecaec
DH		 2852
2853 /* Dirk:FIXME:: The following two expressions make use of the fact that
2854 * the memoizer will accept a subr-object in the place of a function.
2855 * This is not guaranteed to stay this way. */
2856 SCM getm = scm_i_eval_x (scm_list_3 (scm_sym_lambda,
2857 scm_list_1 (sym_o),
2858 scm_list_2 (get, sym_o)),
2859 SCM_EOL);
2860 SCM setm = scm_i_eval_x (scm_list_3 (scm_sym_lambda,
2861 scm_list_2 (sym_o, sym_x),
2862 scm_list_3 (set, sym_o, sym_x)),
2863 SCM_EOL);
2864
80662eda 2865 {
cc95e00a
MV		 2866 SCM name = scm_from_locale_symbol (slot_name);
2867 SCM aname = scm_from_locale_symbol (accessor_name);
80662eda 2868 SCM gf = scm_ensure_accessor (aname);
1afff620
KN		 2869 SCM slot = scm_list_5 (name,
2870 k_class,
2871 slot_class,
2872 setter ? k_accessor : k_getter,
2873 gf);
f8af5c6d 2874 scm_add_method (gf, scm_make (scm_list_5 (scm_class_accessor_method,
1afff620
KN		 2875 k_specializers,
2876 scm_list_1 (class),
2877 k_procedure,
2878 getm)));
80662eda 2879 scm_add_method (scm_setter (gf),
f8af5c6d 2880 scm_make (scm_list_5 (scm_class_accessor_method,
1afff620
KN		 2881 k_specializers,
2882 scm_list_2 (class, scm_class_top),
2883 k_procedure,
2884 setm)));
80662eda 2885 DEFVAR (aname, gf);
6d77c894 2886
dcb410ec 2887 SCM_SET_SLOT (class, scm_si_slots,
1afff620
KN		 2888 scm_append_x (scm_list_2 (SCM_SLOT (class, scm_si_slots),
2889 scm_list_1 (slot))));
21ab2aeb
MD		 2890 {
2891 SCM n = SCM_SLOT (class, scm_si_nfields);
5305df84
LC		 2892 SCM gns = scm_list_n (name, SCM_BOOL_F, get, set, n, scm_from_int (1),
2893 SCM_UNDEFINED);
21ab2aeb
MD		 2894 SCM_SET_SLOT (class, scm_si_getters_n_setters,
2895 scm_append_x (scm_list_2 (SCM_SLOT (class, scm_si_getters_n_setters),
2896 scm_list_1 (gns))));
e11e83f3 2897 SCM_SET_SLOT (class, scm_si_nfields, scm_sum (n, scm_from_int (1)));
21ab2aeb 2898 }
80662eda
MD		 2899 }
2900 }
80662eda
MD		 2901}
2902
2903SCM
2904scm_wrap_object (SCM class, void *data)
2905{
228a24ef
DH		 2906 return scm_double_cell (SCM_UNPACK (SCM_CDR (class)) | scm_tc3_struct,
2907 (scm_t_bits) data,
2908 0, 0);
80662eda
MD		 2909}
2910
2911SCM scm_components;
2912
2913SCM
2914scm_wrap_component (SCM class, SCM container, void *data)
2915{
2916 SCM obj = scm_wrap_object (class, data);
2917 SCM handle = scm_hash_fn_create_handle_x (scm_components,
2918 obj,
2919 SCM_BOOL_F,
2920 scm_struct_ihashq,
2921 scm_sloppy_assq,
2922 0);
2923 SCM_SETCDR (handle, container);
2924 return obj;
2925}
2926
2927SCM
2928scm_ensure_accessor (SCM name)
2929{
fdc28395 2930 SCM gf = scm_call_2 (SCM_TOP_LEVEL_LOOKUP_CLOSURE, name, SCM_BOOL_F);
f8af5c6d 2931 if (!SCM_IS_A_P (gf, scm_class_accessor))
80662eda 2932 {
1afff620 2933 gf = scm_make (scm_list_3 (scm_class_generic, k_name, name));
f8af5c6d 2934 gf = scm_make (scm_list_5 (scm_class_accessor,
1afff620 2935 k_name, name, k_setter, gf));
80662eda
MD		 2936 }
2937 return gf;
2938}
2939
2940SCM_SYMBOL (sym_internal_add_method_x, "internal-add-method!");
2941
2942void
2943scm_add_method (SCM gf, SCM m)
2944{
1afff620 2945 scm_eval (scm_list_3 (sym_internal_add_method_x, gf, m), scm_module_goops);
80662eda
MD		 2946}
2947
2948#ifdef GUILE_DEBUG
2949/*
2950 * Debugging utilities
2951 */
2952
398d8ee1
KN		 2953SCM_DEFINE (scm_pure_generic_p, "pure-generic?", 1, 0, 0,
2954 (SCM obj),
6bcefd15 2955 "Return @code{#t} if @var{obj} is a pure generic.")
398d8ee1 2956#define FUNC_NAME s_scm_pure_generic_p
80662eda 2957{
7888309b 2958 return scm_from_bool (SCM_PUREGENERICP (obj));
80662eda 2959}
398d8ee1 2960#undef FUNC_NAME
80662eda
MD		 2961
2962#endif /* GUILE_DEBUG */
2963
2964/*
2965 * Initialization
2966 */
2967
398d8ee1
KN		 2968SCM_DEFINE (scm_sys_goops_loaded, "%goops-loaded", 0, 0, 0,
2969 (),
6bcefd15
MG		 2970 "Announce that GOOPS is loaded and perform initialization\n"
2971 "on the C level which depends on the loaded GOOPS modules.")
398d8ee1 2972#define FUNC_NAME s_scm_sys_goops_loaded
80662eda
MD		 2973{
2974 goops_loaded_p = 1;
86d31dfe
MV		 2975 var_compute_applicable_methods =
2976 scm_sym2var (sym_compute_applicable_methods, scm_goops_lookup_closure,
2977 SCM_BOOL_F);
a48d60b1 2978 setup_extended_primitive_generics ();
80662eda
MD		 2979 return SCM_UNSPECIFIED;
2980}
398d8ee1 2981#undef FUNC_NAME
80662eda
MD		 2982
2983SCM scm_module_goops;
2984
abd28220
MV		 2985SCM
2986scm_init_goops_builtins (void)
80662eda 2987{
abd28220 2988 scm_module_goops = scm_current_module ();
80662eda
MD		 2989 scm_goops_lookup_closure = scm_module_lookup_closure (scm_module_goops);
2990
6d77c894 2991 /* Not really necessary right now, but who knows...
0ba8a0a5
MV		 2992 */
2993 scm_permanent_object (scm_module_goops);
2994 scm_permanent_object (scm_goops_lookup_closure);
2995
80662eda 2996 scm_components = scm_permanent_object (scm_make_weak_key_hash_table
e11e83f3 2997 (scm_from_int (37)));
80662eda
MD		 2998
2999 goops_rstate = scm_c_make_rstate ("GOOPS", 5);
3000
3001#include "libguile/goops.x"
3002
1afff620 3003 list_of_no_method = scm_permanent_object (scm_list_1 (sym_no_method));
80662eda 3004
bb764c0e 3005 hell = scm_calloc (hell_size * sizeof (*hell));
2132f0d2 3006 hell_mutex = scm_permanent_object (scm_make_mutex ());
80662eda
MD		 3007
3008 create_basic_classes ();
3009 create_standard_classes ();
3010 create_smob_classes ();
3011 create_struct_classes ();
3012 create_port_classes ();
3013
3014 {
cc95e00a 3015 SCM name = scm_from_locale_symbol ("no-applicable-method");
80662eda 3016 scm_no_applicable_method
1afff620
KN		 3017 = scm_permanent_object (scm_make (scm_list_3 (scm_class_generic,
3018 k_name,
3019 name)));
80662eda
MD		 3020 DEFVAR (name, scm_no_applicable_method);
3021 }
abd28220
MV		 3022
3023 return SCM_UNSPECIFIED;
80662eda
MD		 3024}
3025
3026void
abd28220 3027scm_init_goops ()
80662eda 3028{
9a441ddb
MV		 3029 scm_c_define_gsubr ("%init-goops-builtins", 0, 0, 0,
3030 scm_init_goops_builtins);
80662eda 3031}
23437298
DH		 3032
3033/*
3034 Local Variables:
3035 c-file-style: "gnu"
3036 End:
3037*/
Unnamed repository; edit this file 'description' to name the repository.