1 /* Copyright (C) 1998-2004,2008-2015,2017
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 License
6 * as published by the Free Software Foundation; either version 3 of
7 * the License, or (at your option) any later version.
8 *
9 * This library is distributed in the hope that it will be useful, but
10 * 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
17 * 02110-1301 USA
18 */
19
20
21 /* This software is a derivative work of other copyrighted softwares; the
22 * copyright notices of these softwares are placed in the file COPYRIGHTS
23 *
24 * This file is based upon stklos.c from the STk distribution by
25 * Erick Gallesio <eg@unice.fr>.
26 */
27
28 #ifdef HAVE_CONFIG_H
29 # include <config.h>
30 #endif
31
32 #include "libguile/_scm.h"
33 #include "libguile/async.h"
34 #include "libguile/chars.h"
35 #include "libguile/dynwind.h"
36 #include "libguile/eval.h"
37 #include "libguile/gsubr.h"
38 #include "libguile/hashtab.h"
39 #include "libguile/keywords.h"
40 #include "libguile/macros.h"
41 #include "libguile/modules.h"
42 #include "libguile/ports.h"
43 #include "libguile/ports-internal.h"
44 #include "libguile/procprop.h"
45 #include "libguile/programs.h"
46 #include "libguile/smob.h"
47 #include "libguile/strings.h"
48 #include "libguile/strports.h"
49 #include "libguile/vectors.h"
50
51 #include "libguile/validate.h"
52 #include "libguile/goops.h"
53
54 /* Objects have identity, so references to classes and instances are by
55 value, not by reference. Redefinition of a class or modification of
56 an instance causes in-place update; you can think of GOOPS as
57 building in its own indirection, and for that reason referring to
58 GOOPS values by variable reference is unnecessary.
59
60 References to ordinary procedures is by reference (by variable),
61 though, as in the rest of Guile. */
62
63 SCM_KEYWORD (k_name, "name");
64 SCM_KEYWORD (k_setter, "setter");
65 SCM_SYMBOL (sym_redefined, "redefined");
66 SCM_GLOBAL_SYMBOL (scm_sym_args, "args");
67
68 static int goops_loaded_p = 0;
69
70 static SCM var_make_standard_class = SCM_BOOL_F;
71 static SCM var_change_class = SCM_BOOL_F;
72 static SCM var_make = SCM_BOOL_F;
73 static SCM var_inherit_applicable = SCM_BOOL_F;
74 static SCM var_class_name = SCM_BOOL_F;
75 static SCM var_class_direct_supers = SCM_BOOL_F;
76 static SCM var_class_direct_slots = SCM_BOOL_F;
77 static SCM var_class_direct_subclasses = SCM_BOOL_F;
78 static SCM var_class_direct_methods = SCM_BOOL_F;
79 static SCM var_class_precedence_list = SCM_BOOL_F;
80 static SCM var_class_slots = SCM_BOOL_F;
81
82 static SCM var_generic_function_methods = SCM_BOOL_F;
83 static SCM var_method_generic_function = SCM_BOOL_F;
84 static SCM var_method_specializers = SCM_BOOL_F;
85 static SCM var_method_procedure = SCM_BOOL_F;
86
87 static SCM var_slot_ref = SCM_BOOL_F;
88 static SCM var_slot_set_x = SCM_BOOL_F;
89 static SCM var_slot_bound_p = SCM_BOOL_F;
90 static SCM var_slot_exists_p = SCM_BOOL_F;
91
92 /* These variables are filled in by the object system when loaded. */
93 static SCM class_boolean, class_char, class_pair;
94 static SCM class_procedure, class_string, class_symbol;
95 static SCM class_primitive_generic;
96 static SCM class_vector, class_null;
97 static SCM class_integer, class_real, class_complex, class_fraction;
98 static SCM class_unknown;
99 static SCM class_top, class_class;
100 static SCM class_applicable;
101 static SCM class_applicable_struct, class_applicable_struct_with_setter;
102 static SCM class_generic, class_generic_with_setter;
103 static SCM class_accessor;
104 static SCM class_extended_generic, class_extended_generic_with_setter;
105 static SCM class_extended_accessor;
106 static SCM class_method;
107 static SCM class_accessor_method;
108 static SCM class_procedure_class;
109 static SCM class_applicable_struct_class;
110 static SCM class_applicable_struct_with_setter_class;
111 static SCM class_number, class_list;
112 static SCM class_keyword;
113 static SCM class_syntax;
114 static SCM class_atomic_box;
115 static SCM class_port, class_input_output_port;
116 static SCM class_input_port, class_output_port;
117
118 static SCM class_foreign;
119 static SCM class_hashtable;
120 static SCM class_fluid;
121 static SCM class_dynamic_state;
122 static SCM class_frame;
123 static SCM class_vm_cont;
124 static SCM class_bytevector;
125 static SCM class_uvec;
126 static SCM class_array;
127 static SCM class_bitvector;
128
129 static SCM vtable_class_map = SCM_BOOL_F;
130
131 /* SMOB classes. */
132 SCM scm_i_smob_class[SCM_I_MAX_SMOB_TYPE_COUNT];
133
134 SCM scm_module_goops;
135
136 static SCM scm_sys_make_vtable_vtable (SCM layout);
137 static SCM scm_sys_init_layout_x (SCM class, SCM layout);
138 static SCM scm_sys_clear_fields_x (SCM obj, SCM unbound);
139 static SCM scm_sys_goops_early_init (void);
140 static SCM scm_sys_goops_loaded (void);
141
142
143
144
145 SCM_DEFINE (scm_sys_make_vtable_vtable, "%make-vtable-vtable", 1, 0, 0,
146 (SCM layout),
147 "")
148 #define FUNC_NAME s_scm_sys_make_vtable_vtable
149 {
150 return scm_i_make_vtable_vtable (layout);
151 }
152 #undef FUNC_NAME
153
154 SCM
scm_make_standard_class(SCM meta,SCM name,SCM dsupers,SCM dslots)155 scm_make_standard_class (SCM meta, SCM name, SCM dsupers, SCM dslots)
156 {
157 return scm_call_4 (scm_variable_ref (var_make_standard_class),
158 meta, name, dsupers, dslots);
159 }
160
161 SCM_DEFINE (scm_sys_init_layout_x, "%init-layout!", 2, 0, 0,
162 (SCM class, SCM layout),
163 "")
164 #define FUNC_NAME s_scm_sys_init_layout_x
165 {
166 SCM_VALIDATE_INSTANCE (1, class);
167 SCM_ASSERT (!scm_is_symbol (SCM_VTABLE_LAYOUT (class)), class, 1, FUNC_NAME);
168 SCM_VALIDATE_STRING (2, layout);
169
170 SCM_SET_VTABLE_LAYOUT (class, scm_make_struct_layout (layout));
171 scm_i_struct_inherit_vtable_magic (SCM_CLASS_OF (class), class);
172 SCM_SET_CLASS_FLAGS (class, SCM_CLASSF_GOOPS_OR_VALID);
173
174 return SCM_UNSPECIFIED;
175 }
176 #undef FUNC_NAME
177
178
179
180
181 /* This function is used for efficient type dispatch. */
182 SCM_DEFINE (scm_class_of, "class-of", 1, 0, 0,
183 (SCM x),
184 "Return the class of @var{x}.")
185 #define FUNC_NAME s_scm_class_of
186 {
187 switch (SCM_ITAG3 (x))
188 {
189 case scm_tc3_int_1:
190 case scm_tc3_int_2:
191 return class_integer;
192
193 case scm_tc3_imm24:
194 if (SCM_CHARP (x))
195 return class_char;
196 else if (scm_is_bool (x))
197 return class_boolean;
198 else if (scm_is_null (x))
199 return class_null;
200 else
201 return class_unknown;
202
203 case scm_tc3_cons:
204 switch (SCM_TYP7 (x))
205 {
206 case scm_tcs_cons_nimcar:
207 return class_pair;
208 case scm_tc7_symbol:
209 return class_symbol;
210 case scm_tc7_vector:
211 case scm_tc7_wvect:
212 return class_vector;
213 case scm_tc7_pointer:
214 return class_foreign;
215 case scm_tc7_hashtable:
216 return class_hashtable;
217 case scm_tc7_fluid:
218 return class_fluid;
219 case scm_tc7_dynamic_state:
220 return class_dynamic_state;
221 case scm_tc7_frame:
222 return class_frame;
223 case scm_tc7_keyword:
224 return class_keyword;
225 case scm_tc7_syntax:
226 return class_syntax;
227 case scm_tc7_atomic_box:
228 return class_atomic_box;
229 case scm_tc7_vm_cont:
230 return class_vm_cont;
231 case scm_tc7_bytevector:
232 if (SCM_BYTEVECTOR_ELEMENT_TYPE (x) == SCM_ARRAY_ELEMENT_TYPE_VU8)
233 return class_bytevector;
234 else
235 return class_uvec;
236 case scm_tc7_array:
237 return class_array;
238 case scm_tc7_bitvector:
239 return class_bitvector;
240 case scm_tc7_string:
241 return class_string;
242 case scm_tc7_number:
243 switch SCM_TYP16 (x) {
244 case scm_tc16_big:
245 return class_integer;
246 case scm_tc16_real:
247 return class_real;
248 case scm_tc16_complex:
249 return class_complex;
250 case scm_tc16_fraction:
251 return class_fraction;
252 }
253 case scm_tc7_program:
254 if (SCM_PROGRAM_IS_PRIMITIVE_GENERIC (x)
255 && SCM_UNPACK (*SCM_SUBR_GENERIC (x)))
256 return class_primitive_generic;
257 else
258 return class_procedure;
259
260 case scm_tc7_smob:
261 {
262 scm_t_bits type = SCM_TYP16 (x);
263 if (type != scm_tc16_port_with_ps)
264 return scm_i_smob_class[SCM_TC2SMOBNUM (type)];
265 x = SCM_PORT_WITH_PS_PORT (x);
266 /* fall through to ports */
267 }
268 case scm_tc7_port:
269 {
270 scm_t_port_type *ptob = SCM_PORT_TYPE (x);
271 if (SCM_INPUT_PORT_P (x))
272 {
273 if (SCM_OUTPUT_PORT_P (x))
274 return ptob->input_output_class;
275 return ptob->input_class;
276 }
277 return ptob->output_class;
278 }
279 case scm_tcs_struct:
280 if (SCM_OBJ_CLASS_FLAGS (x) & SCM_CLASSF_GOOPS_VALID)
281 /* A GOOPS object with a valid class. */
282 return SCM_CLASS_OF (x);
283 else if (SCM_OBJ_CLASS_FLAGS (x) & SCM_CLASSF_GOOPS)
284 /* A GOOPS object whose class might have been redefined. */
285 {
286 SCM class = SCM_CLASS_OF (x);
287 SCM new_class = scm_slot_ref (class, sym_redefined);
288 if (!scm_is_false (new_class))
289 scm_change_object_class (x, class, new_class);
290 /* Re-load class from instance. */
291 return SCM_CLASS_OF (x);
292 }
293 else
294 return scm_i_define_class_for_vtable (SCM_CLASS_OF (x));
295 default:
296 if (scm_is_pair (x))
297 return class_pair;
298 else
299 return class_unknown;
300 }
301
302 case scm_tc3_struct:
303 case scm_tc3_tc7_1:
304 case scm_tc3_tc7_2:
305 /* case scm_tc3_unused: */
306 /* Never reached */
307 break;
308 }
309 return class_unknown;
310 }
311 #undef FUNC_NAME
312
313
314
315
316 SCM_DEFINE (scm_instance_p, "instance?", 1, 0, 0,
317 (SCM obj),
318 "Return @code{#t} if @var{obj} is an instance.")
319 #define FUNC_NAME s_scm_instance_p
320 {
321 return scm_from_bool (SCM_INSTANCEP (obj));
322 }
323 #undef FUNC_NAME
324
325 int
scm_is_generic(SCM x)326 scm_is_generic (SCM x)
327 {
328 return SCM_INSTANCEP (x) && SCM_SUBCLASSP (SCM_CLASS_OF (x), class_generic);
329 }
330
331 int
scm_is_method(SCM x)332 scm_is_method (SCM x)
333 {
334 return SCM_INSTANCEP (x) && SCM_SUBCLASSP (SCM_CLASS_OF (x), class_method);
335 }
336
337
338
339
340 SCM
scm_class_name(SCM obj)341 scm_class_name (SCM obj)
342 {
343 return scm_call_1 (scm_variable_ref (var_class_name), obj);
344 }
345
346 SCM
scm_class_direct_supers(SCM obj)347 scm_class_direct_supers (SCM obj)
348 {
349 return scm_call_1 (scm_variable_ref (var_class_direct_supers), obj);
350 }
351
352 SCM
scm_class_direct_slots(SCM obj)353 scm_class_direct_slots (SCM obj)
354 {
355 return scm_call_1 (scm_variable_ref (var_class_direct_slots), obj);
356 }
357
358 SCM
scm_class_direct_subclasses(SCM obj)359 scm_class_direct_subclasses (SCM obj)
360 {
361 return scm_call_1 (scm_variable_ref (var_class_direct_subclasses), obj);
362 }
363
364 SCM
scm_class_direct_methods(SCM obj)365 scm_class_direct_methods (SCM obj)
366 {
367 return scm_call_1 (scm_variable_ref (var_class_direct_methods), obj);
368 }
369
370 SCM
scm_class_precedence_list(SCM obj)371 scm_class_precedence_list (SCM obj)
372 {
373 return scm_call_1 (scm_variable_ref (var_class_precedence_list), obj);
374 }
375
376 SCM
scm_class_slots(SCM obj)377 scm_class_slots (SCM obj)
378 {
379 return scm_call_1 (scm_variable_ref (var_class_slots), obj);
380 }
381
382
383
384
385 SCM_DEFINE (scm_generic_function_name, "generic-function-name", 1, 0, 0,
386 (SCM obj),
387 "Return the name of the generic function @var{obj}.")
388 #define FUNC_NAME s_scm_generic_function_name
389 {
390 SCM_VALIDATE_GENERIC (1, obj);
391 return scm_procedure_property (obj, scm_sym_name);
392 }
393 #undef FUNC_NAME
394
395 SCM
scm_generic_function_methods(SCM obj)396 scm_generic_function_methods (SCM obj)
397 {
398 return scm_call_1 (scm_variable_ref (var_generic_function_methods), obj);
399 }
400
401 SCM
scm_method_generic_function(SCM obj)402 scm_method_generic_function (SCM obj)
403 {
404 return scm_call_1 (scm_variable_ref (var_method_generic_function), obj);
405 }
406
407 SCM
scm_method_specializers(SCM obj)408 scm_method_specializers (SCM obj)
409 {
410 return scm_call_1 (scm_variable_ref (var_method_specializers), obj);
411 }
412
413 SCM
scm_method_procedure(SCM obj)414 scm_method_procedure (SCM obj)
415 {
416 return scm_call_1 (scm_variable_ref (var_method_procedure), obj);
417 }
418
419
420
421
422 SCM
scm_slot_ref(SCM obj,SCM slot_name)423 scm_slot_ref (SCM obj, SCM slot_name)
424 {
425 return scm_call_2 (scm_variable_ref (var_slot_ref), obj, slot_name);
426 }
427
428 SCM
scm_slot_set_x(SCM obj,SCM slot_name,SCM value)429 scm_slot_set_x (SCM obj, SCM slot_name, SCM value)
430 {
431 return scm_call_3 (scm_variable_ref (var_slot_set_x), obj, slot_name, value);
432 }
433
434 SCM
scm_slot_bound_p(SCM obj,SCM slot_name)435 scm_slot_bound_p (SCM obj, SCM slot_name)
436 {
437 return scm_call_2 (scm_variable_ref (var_slot_bound_p), obj, slot_name);
438 }
439
440 SCM
scm_slot_exists_p(SCM obj,SCM slot_name)441 scm_slot_exists_p (SCM obj, SCM slot_name)
442 {
443 return scm_call_2 (scm_variable_ref (var_slot_exists_p), obj, slot_name);
444 }
445
446
447
448
449 SCM_DEFINE (scm_sys_clear_fields_x, "%clear-fields!", 2, 0, 0,
450 (SCM obj, SCM unbound),
451 "")
452 #define FUNC_NAME s_scm_sys_clear_fields_x
453 {
454 scm_t_signed_bits n, i;
455 SCM vtable, layout;
456
457 SCM_VALIDATE_STRUCT (1, obj);
458 vtable = SCM_STRUCT_VTABLE (obj);
459
460 n = SCM_STRUCT_DATA_REF (vtable, scm_vtable_index_size);
461 layout = SCM_VTABLE_LAYOUT (vtable);
462
463 /* Set all SCM-holding slots to the GOOPS unbound value. */
464 for (i = 0; i < n; i++)
465 if (scm_i_symbol_ref (layout, i*2) == 'p')
466 SCM_STRUCT_SLOT_SET (obj, i, unbound);
467
468 return SCM_UNSPECIFIED;
469 }
470 #undef FUNC_NAME
471
472
473
474
475 static scm_i_pthread_mutex_t goops_lock = SCM_I_PTHREAD_MUTEX_INITIALIZER;
476
477 SCM_DEFINE (scm_sys_modify_instance, "%modify-instance", 2, 0, 0,
478 (SCM old, SCM new),
479 "Used by change-class to modify objects in place.")
480 #define FUNC_NAME s_scm_sys_modify_instance
481 {
482 SCM_VALIDATE_INSTANCE (1, old);
483 SCM_VALIDATE_INSTANCE (2, new);
484
485 /* Exchange the data contained in old and new. We exchange rather than
486 * scratch the old value with new to be correct with GC.
487 * See "Class redefinition protocol above".
488 */
489 scm_i_pthread_mutex_lock (&goops_lock);
490 {
491 scm_t_bits word0, word1;
492 word0 = SCM_CELL_WORD_0 (old);
493 word1 = SCM_CELL_WORD_1 (old);
494 SCM_SET_CELL_WORD_0 (old, SCM_CELL_WORD_0 (new));
495 SCM_SET_CELL_WORD_1 (old, SCM_CELL_WORD_1 (new));
496 SCM_SET_CELL_WORD_0 (new, word0);
497 SCM_SET_CELL_WORD_1 (new, word1);
498 }
499 scm_i_pthread_mutex_unlock (&goops_lock);
500 return SCM_UNSPECIFIED;
501 }
502 #undef FUNC_NAME
503
504 SCM_DEFINE (scm_sys_modify_class, "%modify-class", 2, 0, 0,
505 (SCM old, SCM new),
506 "")
507 #define FUNC_NAME s_scm_sys_modify_class
508 {
509 SCM_VALIDATE_CLASS (1, old);
510 SCM_VALIDATE_CLASS (2, new);
511
512 scm_i_pthread_mutex_lock (&goops_lock);
513 {
514 scm_t_bits word0, word1;
515 word0 = SCM_CELL_WORD_0 (old);
516 word1 = SCM_CELL_WORD_1 (old);
517 SCM_SET_CELL_WORD_0 (old, SCM_CELL_WORD_0 (new));
518 SCM_SET_CELL_WORD_1 (old, SCM_CELL_WORD_1 (new));
519 SCM_STRUCT_DATA (old)[scm_vtable_index_self] = SCM_UNPACK (old);
520 SCM_SET_CELL_WORD_0 (new, word0);
521 SCM_SET_CELL_WORD_1 (new, word1);
522 SCM_STRUCT_DATA (new)[scm_vtable_index_self] = SCM_UNPACK (new);
523 }
524 scm_i_pthread_mutex_unlock (&goops_lock);
525 return SCM_UNSPECIFIED;
526 }
527 #undef FUNC_NAME
528
529 /* When instances change class, they finally get a new body, but
530 * before that, they go through purgatory in hell. Odd as it may
531 * seem, this data structure saves us from eternal suffering in
532 * infinite recursions.
533 */
534
535 static scm_t_bits **hell;
536 static long n_hell = 1; /* one place for the evil one himself */
537 static long hell_size = 4;
538 static SCM hell_mutex;
539
540 static long
burnin(SCM o)541 burnin (SCM o)
542 {
543 long i;
544 for (i = 1; i < n_hell; ++i)
545 if (SCM_STRUCT_DATA (o) == hell[i])
546 return i;
547 return 0;
548 }
549
550 static void
go_to_hell(void * o)551 go_to_hell (void *o)
552 {
553 SCM obj = *(SCM*)o;
554 scm_lock_mutex (hell_mutex);
555 if (n_hell >= hell_size)
556 {
557 hell_size *= 2;
558 hell = scm_realloc (hell, hell_size * sizeof(*hell));
559 }
560 hell[n_hell++] = SCM_STRUCT_DATA (obj);
561 scm_unlock_mutex (hell_mutex);
562 }
563
564 static void
go_to_heaven(void * o)565 go_to_heaven (void *o)
566 {
567 SCM obj = *(SCM*)o;
568 scm_lock_mutex (hell_mutex);
569 hell[burnin (obj)] = hell[--n_hell];
570 scm_unlock_mutex (hell_mutex);
571 }
572
573
574 static SCM
purgatory(SCM obj,SCM new_class)575 purgatory (SCM obj, SCM new_class)
576 {
577 return scm_call_2 (SCM_VARIABLE_REF (var_change_class), obj, new_class);
578 }
579
580 /* This function calls the generic function change-class for all
581 * instances which aren't currently undergoing class change.
582 */
583
584 void
scm_change_object_class(SCM obj,SCM old_class SCM_UNUSED,SCM new_class)585 scm_change_object_class (SCM obj, SCM old_class SCM_UNUSED, SCM new_class)
586 {
587 if (!burnin (obj))
588 {
589 scm_dynwind_begin (SCM_F_DYNWIND_REWINDABLE);
590 scm_dynwind_rewind_handler (go_to_hell, &obj, SCM_F_WIND_EXPLICITLY);
591 scm_dynwind_unwind_handler (go_to_heaven, &obj, SCM_F_WIND_EXPLICITLY);
592 purgatory (obj, new_class);
593 scm_dynwind_end ();
594 }
595 }
596
597
598
599
600 /* Primitive generics: primitives that can dispatch to generics if their
601 arguments fail to apply. */
602
603 SCM_DEFINE (scm_generic_capability_p, "generic-capability?", 1, 0, 0,
604 (SCM proc),
605 "")
606 #define FUNC_NAME s_scm_generic_capability_p
607 {
608 SCM_ASSERT (scm_is_true (scm_procedure_p (proc)),
609 proc, SCM_ARG1, FUNC_NAME);
610 return (SCM_PRIMITIVE_GENERIC_P (proc) ? SCM_BOOL_T : SCM_BOOL_F);
611 }
612 #undef FUNC_NAME
613
614 SCM_DEFINE (scm_enable_primitive_generic_x, "enable-primitive-generic!", 0, 0, 1,
615 (SCM subrs),
616 "")
617 #define FUNC_NAME s_scm_enable_primitive_generic_x
618 {
619 SCM_VALIDATE_REST_ARGUMENT (subrs);
620 while (!scm_is_null (subrs))
621 {
622 SCM subr = SCM_CAR (subrs);
623 SCM_ASSERT (SCM_PRIMITIVE_GENERIC_P (subr), subr, SCM_ARGn, FUNC_NAME);
624 SCM_SET_SUBR_GENERIC (subr,
625 scm_make (scm_list_3 (class_generic,
626 k_name,
627 SCM_SUBR_NAME (subr))));
628 subrs = SCM_CDR (subrs);
629 }
630 return SCM_UNSPECIFIED;
631 }
632 #undef FUNC_NAME
633
634 SCM_DEFINE (scm_set_primitive_generic_x, "set-primitive-generic!", 2, 0, 0,
635 (SCM subr, SCM generic),
636 "")
637 #define FUNC_NAME s_scm_set_primitive_generic_x
638 {
639 SCM_ASSERT (SCM_PRIMITIVE_GENERIC_P (subr), subr, SCM_ARG1, FUNC_NAME);
640 SCM_ASSERT (SCM_GENERICP (generic), generic, SCM_ARG2, FUNC_NAME);
641 SCM_SET_SUBR_GENERIC (subr, generic);
642 return SCM_UNSPECIFIED;
643 }
644 #undef FUNC_NAME
645
646 SCM_DEFINE (scm_primitive_generic_generic, "primitive-generic-generic", 1, 0, 0,
647 (SCM subr),
648 "")
649 #define FUNC_NAME s_scm_primitive_generic_generic
650 {
651 if (SCM_PRIMITIVE_GENERIC_P (subr))
652 {
653 if (!SCM_UNPACK (*SCM_SUBR_GENERIC (subr)))
654 scm_enable_primitive_generic_x (scm_list_1 (subr));
655 return *SCM_SUBR_GENERIC (subr);
656 }
657 SCM_WRONG_TYPE_ARG (SCM_ARG1, subr);
658 }
659 #undef FUNC_NAME
660
661 SCM
scm_wta_dispatch_0(SCM gf,const char * subr)662 scm_wta_dispatch_0 (SCM gf, const char *subr)
663 {
664 if (!SCM_UNPACK (gf))
665 scm_error_num_args_subr (subr);
666
667 return scm_call_0 (gf);
668 }
669
670 SCM
scm_wta_dispatch_1(SCM gf,SCM a1,int pos,const char * subr)671 scm_wta_dispatch_1 (SCM gf, SCM a1, int pos, const char *subr)
672 {
673 if (!SCM_UNPACK (gf))
674 scm_wrong_type_arg (subr, pos, a1);
675
676 return scm_call_1 (gf, a1);
677 }
678
679 SCM
scm_wta_dispatch_2(SCM gf,SCM a1,SCM a2,int pos,const char * subr)680 scm_wta_dispatch_2 (SCM gf, SCM a1, SCM a2, int pos, const char *subr)
681 {
682 if (!SCM_UNPACK (gf))
683 scm_wrong_type_arg (subr, pos, (pos == SCM_ARG1) ? a1 : a2);
684
685 return scm_call_2 (gf, a1, a2);
686 }
687
688 SCM
scm_wta_dispatch_n(SCM gf,SCM args,int pos,const char * subr)689 scm_wta_dispatch_n (SCM gf, SCM args, int pos, const char *subr)
690 {
691 if (!SCM_UNPACK (gf))
692 scm_wrong_type_arg (subr, pos, scm_list_ref (args, scm_from_int (pos)));
693
694 return scm_apply_0 (gf, args);
695 }
696
697
698
699
700 SCM
scm_make(SCM args)701 scm_make (SCM args)
702 {
703 return scm_apply_0 (scm_variable_ref (var_make), args);
704 }
705
706
707
708
709 /* SMOB, struct, and port classes. */
710
711 static SCM
make_class_name(const char * prefix,const char * type_name,const char * suffix)712 make_class_name (const char *prefix, const char *type_name, const char *suffix)
713 {
714 if (!type_name)
715 type_name = "";
716 return scm_string_to_symbol (scm_string_append
717 (scm_list_3 (scm_from_utf8_string (prefix),
718 scm_from_utf8_string (type_name),
719 scm_from_utf8_string (suffix))));
720 }
721
722 SCM
scm_make_extended_class(char const * type_name,int applicablep)723 scm_make_extended_class (char const *type_name, int applicablep)
724 {
725 SCM name, meta, supers;
726
727 name = make_class_name ("<", type_name, ">");
728 meta = class_class;
729
730 if (applicablep)
731 supers = scm_list_1 (class_applicable);
732 else
733 supers = scm_list_1 (class_top);
734
735 return scm_make_standard_class (meta, name, supers, SCM_EOL);
736 }
737
738 void
scm_i_inherit_applicable(SCM c)739 scm_i_inherit_applicable (SCM c)
740 {
741 scm_call_1 (scm_variable_ref (var_inherit_applicable), c);
742 }
743
744 static void
create_smob_classes(void)745 create_smob_classes (void)
746 {
747 long i;
748
749 for (i = 0; i < SCM_I_MAX_SMOB_TYPE_COUNT; ++i)
750 scm_i_smob_class[i] = SCM_BOOL_F;
751
752 for (i = 0; i < scm_numsmob; ++i)
753 if (scm_is_false (scm_i_smob_class[i]))
754 scm_i_smob_class[i] = scm_make_extended_class (SCM_SMOBNAME (i),
755 scm_smobs[i].apply != 0);
756 }
757
758 struct pre_goops_port_type
759 {
760 scm_t_port_type *ptob;
761 struct pre_goops_port_type *prev;
762 };
763 struct pre_goops_port_type *pre_goops_port_types;
764
765 static void
make_port_classes(scm_t_port_type * ptob)766 make_port_classes (scm_t_port_type *ptob)
767 {
768 SCM name, meta, super, supers;
769
770 meta = class_class;
771
772 name = make_class_name ("<", ptob->name, "-port>");
773 supers = scm_list_1 (class_port);
774 super = scm_make_standard_class (meta, name, supers, SCM_EOL);
775
776 name = make_class_name ("<", ptob->name, "-input-port>");
777 supers = scm_list_2 (super, class_input_port);
778 ptob->input_class = scm_make_standard_class (meta, name, supers, SCM_EOL);
779
780 name = make_class_name ("<", ptob->name, "-output-port>");
781 supers = scm_list_2 (super, class_output_port);
782 ptob->output_class = scm_make_standard_class (meta, name, supers, SCM_EOL);
783
784 name = make_class_name ("<", ptob->name, "-input-output-port>");
785 supers = scm_list_2 (super, class_input_output_port);
786 ptob->input_output_class =
787 scm_make_standard_class (meta, name, supers, SCM_EOL);
788 }
789
790 void
scm_make_port_classes(scm_t_port_type * ptob)791 scm_make_port_classes (scm_t_port_type *ptob)
792 {
793 ptob->input_class = SCM_BOOL_F;
794 ptob->output_class = SCM_BOOL_F;
795 ptob->input_output_class = SCM_BOOL_F;
796
797 if (!goops_loaded_p)
798 {
799 /* Not really a pair. */
800 struct pre_goops_port_type *link;
801 link = scm_gc_typed_calloc (struct pre_goops_port_type);
802 link->ptob = ptob;
803 link->prev = pre_goops_port_types;
804 pre_goops_port_types = link;
805 return;
806 }
807
808 make_port_classes (ptob);
809 }
810
811 static void
create_port_classes(void)812 create_port_classes (void)
813 {
814 while (pre_goops_port_types)
815 {
816 make_port_classes (pre_goops_port_types->ptob);
817 pre_goops_port_types = pre_goops_port_types->prev;
818 }
819 }
820
821 SCM
scm_i_define_class_for_vtable(SCM vtable)822 scm_i_define_class_for_vtable (SCM vtable)
823 {
824 SCM class;
825
826 scm_i_pthread_mutex_lock (&scm_i_misc_mutex);
827 if (scm_is_false (vtable_class_map))
828 vtable_class_map = scm_c_make_weak_table (0, SCM_WEAK_TABLE_KIND_KEY);
829 scm_i_pthread_mutex_unlock (&scm_i_misc_mutex);
830
831 if (scm_is_false (scm_struct_vtable_p (vtable)))
832 abort ();
833
834 class = scm_weak_table_refq (vtable_class_map, vtable, SCM_BOOL_F);
835
836 if (scm_is_false (class))
837 {
838 if (SCM_UNPACK (class_class))
839 {
840 SCM name, meta, supers;
841
842 name = SCM_VTABLE_NAME (vtable);
843 if (scm_is_symbol (name))
844 name = scm_string_to_symbol
845 (scm_string_append
846 (scm_list_3 (scm_from_latin1_string ("<"),
847 scm_symbol_to_string (name),
848 scm_from_latin1_string (">"))));
849 else
850 name = scm_from_latin1_symbol ("<>");
851
852 if (SCM_STRUCT_VTABLE_FLAG_IS_SET (vtable, SCM_VTABLE_FLAG_SETTER))
853 {
854 meta = class_applicable_struct_with_setter_class;
855 supers = scm_list_1 (class_applicable_struct_with_setter);
856 }
857 else if (SCM_STRUCT_VTABLE_FLAG_IS_SET (vtable,
858 SCM_VTABLE_FLAG_APPLICABLE))
859 {
860 meta = class_applicable_struct_class;
861 supers = scm_list_1 (class_applicable_struct);
862 }
863 else
864 {
865 meta = class_class;
866 supers = scm_list_1 (class_top);
867 }
868
869 class = scm_make_standard_class (meta, name, supers, SCM_EOL);
870 }
871 else
872 /* `create_struct_classes' will fill this in later. */
873 class = SCM_BOOL_F;
874
875 /* Don't worry about races. This only happens when creating a
876 vtable, which happens by definition in one thread. */
877 scm_weak_table_putq_x (vtable_class_map, vtable, class);
878 }
879
880 return class;
881 }
882
883 static SCM
make_struct_class(void * closure SCM_UNUSED,SCM vtable,SCM data,SCM prev SCM_UNUSED)884 make_struct_class (void *closure SCM_UNUSED,
885 SCM vtable, SCM data, SCM prev SCM_UNUSED)
886 {
887 if (scm_is_false (data))
888 scm_i_define_class_for_vtable (vtable);
889 return SCM_UNSPECIFIED;
890 }
891
892 static void
create_struct_classes(void)893 create_struct_classes (void)
894 {
895 /* FIXME: take the vtable_class_map while initializing goops? */
896 scm_internal_hash_fold (make_struct_class, 0, SCM_BOOL_F,
897 vtable_class_map);
898 }
899
900
901
902
903 void
scm_load_goops()904 scm_load_goops ()
905 {
906 if (!goops_loaded_p)
907 scm_c_resolve_module ("oop goops");
908 }
909
910 SCM
scm_ensure_accessor(SCM name)911 scm_ensure_accessor (SCM name)
912 {
913 SCM var, gf;
914
915 var = scm_module_variable (scm_current_module (), name);
916 if (SCM_VARIABLEP (var) && !SCM_UNBNDP (SCM_VARIABLE_REF (var)))
917 gf = SCM_VARIABLE_REF (var);
918 else
919 gf = SCM_BOOL_F;
920
921 if (!SCM_IS_A_P (gf, class_accessor))
922 {
923 gf = scm_make (scm_list_3 (class_generic, k_name, name));
924 gf = scm_make (scm_list_5 (class_accessor,
925 k_name, name, k_setter, gf));
926 }
927
928 return gf;
929 }
930
931
932
933
934 SCM_DEFINE (scm_sys_goops_early_init, "%goops-early-init", 0, 0, 0,
935 (),
936 "")
937 #define FUNC_NAME s_scm_sys_goops_early_init
938 {
939 var_make_standard_class = scm_c_lookup ("make-standard-class");
940 var_make = scm_c_lookup ("make");
941 var_inherit_applicable = scm_c_lookup ("inherit-applicable!");
942
943 /* For SCM_SUBCLASSP. */
944 var_class_precedence_list = scm_c_lookup ("class-precedence-list");
945
946 var_slot_ref = scm_c_lookup ("slot-ref");
947 var_slot_set_x = scm_c_lookup ("slot-set!");
948 var_slot_bound_p = scm_c_lookup ("slot-bound?");
949 var_slot_exists_p = scm_c_lookup ("slot-exists?");
950
951 class_class = scm_variable_ref (scm_c_lookup ("<class>"));
952 class_top = scm_variable_ref (scm_c_lookup ("<top>"));
953
954 /* Applicables */
955 class_procedure_class = scm_variable_ref (scm_c_lookup ("<procedure-class>"));
956 class_applicable_struct_class = scm_variable_ref (scm_c_lookup ("<applicable-struct-class>"));
957 class_applicable_struct_with_setter_class =
958 scm_variable_ref (scm_c_lookup ("<applicable-struct-with-setter-class>"));
959
960 class_method = scm_variable_ref (scm_c_lookup ("<method>"));
961 class_accessor_method = scm_variable_ref (scm_c_lookup ("<accessor-method>"));
962 class_applicable = scm_variable_ref (scm_c_lookup ("<applicable>"));
963 class_applicable_struct = scm_variable_ref (scm_c_lookup ("<applicable-struct>"));
964 class_applicable_struct_with_setter = scm_variable_ref (scm_c_lookup ("<applicable-struct-with-setter>"));
965 class_generic = scm_variable_ref (scm_c_lookup ("<generic>"));
966 class_extended_generic = scm_variable_ref (scm_c_lookup ("<extended-generic>"));
967 class_generic_with_setter = scm_variable_ref (scm_c_lookup ("<generic-with-setter>"));
968 class_accessor = scm_variable_ref (scm_c_lookup ("<accessor>"));
969 class_extended_generic_with_setter = scm_variable_ref (scm_c_lookup ("<extended-generic-with-setter>"));
970 class_extended_accessor = scm_variable_ref (scm_c_lookup ("<extended-accessor>"));
971
972 /* Primitive types classes */
973 class_boolean = scm_variable_ref (scm_c_lookup ("<boolean>"));
974 class_char = scm_variable_ref (scm_c_lookup ("<char>"));
975 class_list = scm_variable_ref (scm_c_lookup ("<list>"));
976 class_pair = scm_variable_ref (scm_c_lookup ("<pair>"));
977 class_null = scm_variable_ref (scm_c_lookup ("<null>"));
978 class_string = scm_variable_ref (scm_c_lookup ("<string>"));
979 class_symbol = scm_variable_ref (scm_c_lookup ("<symbol>"));
980 class_vector = scm_variable_ref (scm_c_lookup ("<vector>"));
981 class_foreign = scm_variable_ref (scm_c_lookup ("<foreign>"));
982 class_hashtable = scm_variable_ref (scm_c_lookup ("<hashtable>"));
983 class_fluid = scm_variable_ref (scm_c_lookup ("<fluid>"));
984 class_dynamic_state = scm_variable_ref (scm_c_lookup ("<dynamic-state>"));
985 class_frame = scm_variable_ref (scm_c_lookup ("<frame>"));
986 class_keyword = scm_variable_ref (scm_c_lookup ("<keyword>"));
987 class_syntax = scm_variable_ref (scm_c_lookup ("<syntax>"));
988 class_atomic_box = scm_variable_ref (scm_c_lookup ("<atomic-box>"));
989 class_vm_cont = scm_variable_ref (scm_c_lookup ("<vm-continuation>"));
990 class_bytevector = scm_variable_ref (scm_c_lookup ("<bytevector>"));
991 class_uvec = scm_variable_ref (scm_c_lookup ("<uvec>"));
992 class_array = scm_variable_ref (scm_c_lookup ("<array>"));
993 class_bitvector = scm_variable_ref (scm_c_lookup ("<bitvector>"));
994 class_number = scm_variable_ref (scm_c_lookup ("<number>"));
995 class_complex = scm_variable_ref (scm_c_lookup ("<complex>"));
996 class_real = scm_variable_ref (scm_c_lookup ("<real>"));
997 class_integer = scm_variable_ref (scm_c_lookup ("<integer>"));
998 class_fraction = scm_variable_ref (scm_c_lookup ("<fraction>"));
999 class_unknown = scm_variable_ref (scm_c_lookup ("<unknown>"));
1000 class_procedure = scm_variable_ref (scm_c_lookup ("<procedure>"));
1001 class_primitive_generic = scm_variable_ref (scm_c_lookup ("<primitive-generic>"));
1002 class_port = scm_variable_ref (scm_c_lookup ("<port>"));
1003 class_input_port = scm_variable_ref (scm_c_lookup ("<input-port>"));
1004 class_output_port = scm_variable_ref (scm_c_lookup ("<output-port>"));
1005 class_input_output_port = scm_variable_ref (scm_c_lookup ("<input-output-port>"));
1006
1007 create_smob_classes ();
1008 create_struct_classes ();
1009 create_port_classes ();
1010
1011 return SCM_UNSPECIFIED;
1012 }
1013 #undef FUNC_NAME
1014
1015 SCM_DEFINE (scm_sys_goops_loaded, "%goops-loaded", 0, 0, 0,
1016 (),
1017 "Announce that GOOPS is loaded and perform initialization\n"
1018 "on the C level which depends on the loaded GOOPS modules.")
1019 #define FUNC_NAME s_scm_sys_goops_loaded
1020 {
1021 goops_loaded_p = 1;
1022 var_class_name = scm_c_lookup ("class-name");
1023 var_class_direct_supers = scm_c_lookup ("class-direct-supers");
1024 var_class_direct_slots = scm_c_lookup ("class-direct-slots");
1025 var_class_direct_subclasses = scm_c_lookup ("class-direct-subclasses");
1026 var_class_direct_methods = scm_c_lookup ("class-direct-methods");
1027 var_class_slots = scm_c_lookup ("class-slots");
1028
1029 var_generic_function_methods = scm_c_lookup ("generic-function-methods");
1030 var_method_generic_function = scm_c_lookup ("method-generic-function");
1031 var_method_specializers = scm_c_lookup ("method-specializers");
1032 var_method_procedure = scm_c_lookup ("method-procedure");
1033
1034 var_change_class = scm_c_lookup ("change-class");
1035
1036 #if (SCM_ENABLE_DEPRECATED == 1)
1037 scm_init_deprecated_goops ();
1038 #endif
1039
1040 return SCM_UNSPECIFIED;
1041 }
1042 #undef FUNC_NAME
1043
1044 static void
scm_init_goops_builtins(void * unused)1045 scm_init_goops_builtins (void *unused)
1046 {
1047 scm_module_goops = scm_current_module ();
1048
1049 hell = scm_calloc (hell_size * sizeof (*hell));
1050 hell_mutex = scm_make_mutex ();
1051
1052 #include "libguile/goops.x"
1053
1054 scm_c_define ("vtable-flag-vtable",
1055 scm_from_int (SCM_VTABLE_FLAG_VTABLE));
1056 scm_c_define ("vtable-flag-applicable-vtable",
1057 scm_from_int (SCM_VTABLE_FLAG_APPLICABLE_VTABLE));
1058 scm_c_define ("vtable-flag-setter-vtable",
1059 scm_from_int (SCM_VTABLE_FLAG_SETTER_VTABLE));
1060 scm_c_define ("vtable-flag-validated",
1061 scm_from_int (SCM_VTABLE_FLAG_VALIDATED));
1062 scm_c_define ("vtable-flag-goops-class",
1063 scm_from_int (SCM_VTABLE_FLAG_GOOPS_CLASS));
1064 scm_c_define ("vtable-flag-goops-valid",
1065 scm_from_int (SCM_VTABLE_FLAG_GOOPS_VALID));
1066 scm_c_define ("vtable-flag-goops-slot",
1067 scm_from_int (SCM_VTABLE_FLAG_GOOPS_SLOT));
1068 scm_c_define ("vtable-flag-goops-static",
1069 scm_from_int (SCM_VTABLE_FLAG_GOOPS_STATIC));
1070 }
1071
1072 void
scm_init_goops()1073 scm_init_goops ()
1074 {
1075 scm_c_register_extension ("libguile-" SCM_EFFECTIVE_VERSION,
1076 "scm_init_goops_builtins", scm_init_goops_builtins,
1077 NULL);
1078 }
1079
1080 /*
1081 Local Variables:
1082 c-file-style: "gnu"
1083 End:
1084 */
1085