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