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