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