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