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