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