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