1 /* Copyright (C) 1998,1999,2000,2001,2002,2003,2004,2008,2009,2010,2011,2012,2013,2014,2015
2 * Free Software Foundation, Inc.
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.
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.
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
21 /* This software is a derivative work of other copyrighted softwares; the
22 * copyright notices of these softwares are placed in the file COPYRIGHTS
24 * This file is based upon stklos.c from the STk distribution by
25 * Erick Gallesio <eg@unice.fr>.
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/procprop.h"
44 #include "libguile/programs.h"
45 #include "libguile/smob.h"
46 #include "libguile/strings.h"
47 #include "libguile/strports.h"
48 #include "libguile/vectors.h"
50 #include "libguile/validate.h"
51 #include "libguile/goops.h"
54 #define SCM_IN_PCLASS_INDEX 0
55 #define SCM_OUT_PCLASS_INDEX SCM_I_MAX_PORT_TYPE_COUNT
56 #define SCM_INOUT_PCLASS_INDEX (2 * SCM_I_MAX_PORT_TYPE_COUNT)
58 /* Objects have identity, so references to classes and instances are by
59 value, not by reference. Redefinition of a class or modification of
60 an instance causes in-place update; you can think of GOOPS as
61 building in its own indirection, and for that reason referring to
62 GOOPS values by variable reference is unnecessary.
64 References to ordinary procedures is by reference (by variable),
65 though, as in the rest of Guile. */
67 SCM_KEYWORD (k_name
, "name");
68 SCM_KEYWORD (k_setter
, "setter");
69 SCM_SYMBOL (sym_redefined
, "redefined");
70 SCM_GLOBAL_SYMBOL (scm_sym_args
, "args");
72 static int goops_loaded_p
= 0;
74 static SCM var_make_standard_class
= SCM_BOOL_F
;
75 static SCM var_change_class
= SCM_BOOL_F
;
76 static SCM var_make
= SCM_BOOL_F
;
77 static SCM var_inherit_applicable
= SCM_BOOL_F
;
78 static SCM var_class_name
= SCM_BOOL_F
;
79 static SCM var_class_direct_supers
= SCM_BOOL_F
;
80 static SCM var_class_direct_slots
= SCM_BOOL_F
;
81 static SCM var_class_direct_subclasses
= SCM_BOOL_F
;
82 static SCM var_class_direct_methods
= SCM_BOOL_F
;
83 static SCM var_class_precedence_list
= SCM_BOOL_F
;
84 static SCM var_class_slots
= SCM_BOOL_F
;
86 static SCM var_generic_function_methods
= SCM_BOOL_F
;
87 static SCM var_method_generic_function
= SCM_BOOL_F
;
88 static SCM var_method_specializers
= SCM_BOOL_F
;
89 static SCM var_method_procedure
= SCM_BOOL_F
;
91 static SCM var_slot_ref
= SCM_BOOL_F
;
92 static SCM var_slot_set_x
= SCM_BOOL_F
;
93 static SCM var_slot_bound_p
= SCM_BOOL_F
;
94 static SCM var_slot_exists_p
= SCM_BOOL_F
;
96 /* These variables are filled in by the object system when loaded. */
97 static SCM class_boolean
, class_char
, class_pair
;
98 static SCM class_procedure
, class_string
, class_symbol
;
99 static SCM class_primitive_generic
;
100 static SCM class_vector
, class_null
;
101 static SCM class_integer
, class_real
, class_complex
, class_fraction
;
102 static SCM class_unknown
;
103 static SCM class_top
, class_object
, class_class
;
104 static SCM class_applicable
;
105 static SCM class_applicable_struct
, class_applicable_struct_with_setter
;
106 static SCM class_generic
, class_generic_with_setter
;
107 static SCM class_accessor
;
108 static SCM class_extended_generic
, class_extended_generic_with_setter
;
109 static SCM class_extended_accessor
;
110 static SCM class_method
;
111 static SCM class_accessor_method
;
112 static SCM class_procedure_class
;
113 static SCM class_applicable_struct_class
;
114 static SCM class_applicable_struct_with_setter_class
;
115 static SCM class_number
, class_list
;
116 static SCM class_keyword
;
117 static SCM class_port
, class_input_output_port
;
118 static SCM class_input_port
, class_output_port
;
119 static SCM class_foreign_slot
;
120 static SCM class_self
, class_protected
;
121 static SCM class_hidden
, class_opaque
, class_read_only
;
122 static SCM class_protected_hidden
, class_protected_opaque
, class_protected_read_only
;
123 static SCM class_scm
;
124 static SCM class_int
, class_float
, class_double
;
126 static SCM class_foreign
;
127 static SCM class_hashtable
;
128 static SCM class_fluid
;
129 static SCM class_dynamic_state
;
130 static SCM class_frame
;
131 static SCM class_keyword
;
132 static SCM class_vm_cont
;
133 static SCM class_bytevector
;
134 static SCM class_uvec
;
135 static SCM class_array
;
136 static SCM class_bitvector
;
138 static SCM vtable_class_map
= SCM_BOOL_F
;
140 /* Port classes. Allocate 3 times the maximum number of port types so that
141 input ports, output ports, and in/out ports can be stored at different
142 offsets. See `SCM_IN_PCLASS_INDEX' et al. */
143 SCM scm_i_port_class
[3 * SCM_I_MAX_PORT_TYPE_COUNT
];
146 SCM scm_i_smob_class
[SCM_I_MAX_SMOB_TYPE_COUNT
];
148 SCM scm_module_goops
;
150 static SCM
scm_sys_make_vtable_vtable (SCM layout
);
151 static SCM
scm_sys_init_layout_x (SCM
class, SCM layout
);
152 static SCM
scm_sys_clear_fields_x (SCM obj
, SCM unbound
);
153 static SCM
scm_sys_goops_early_init (void);
154 static SCM
scm_sys_goops_loaded (void);
159 SCM_DEFINE (scm_sys_make_vtable_vtable
, "%make-vtable-vtable", 1, 0, 0,
162 #define FUNC_NAME s_scm_sys_make_vtable_vtable
164 return scm_i_make_vtable_vtable (layout
);
169 scm_make_standard_class (SCM meta
, SCM name
, SCM dsupers
, SCM dslots
)
171 return scm_call_4 (scm_variable_ref (var_make_standard_class
),
172 meta
, name
, dsupers
, dslots
);
175 SCM_DEFINE (scm_sys_init_layout_x
, "%init-layout!", 2, 0, 0,
176 (SCM
class, SCM layout
),
178 #define FUNC_NAME s_scm_sys_init_layout_x
180 SCM_VALIDATE_INSTANCE (1, class);
181 SCM_ASSERT (!scm_is_symbol (SCM_VTABLE_LAYOUT (class)), class, 1, FUNC_NAME
);
182 SCM_VALIDATE_STRING (2, layout
);
184 SCM_SET_VTABLE_LAYOUT (class, scm_make_struct_layout (layout
));
185 scm_i_struct_inherit_vtable_magic (SCM_CLASS_OF (class), class);
186 SCM_SET_CLASS_FLAGS (class, SCM_CLASSF_GOOPS_OR_VALID
);
188 return SCM_UNSPECIFIED
;
195 /* This function is used for efficient type dispatch. */
196 SCM_DEFINE (scm_class_of
, "class-of", 1, 0, 0,
198 "Return the class of @var{x}.")
199 #define FUNC_NAME s_scm_class_of
201 switch (SCM_ITAG3 (x
))
205 return class_integer
;
210 else if (scm_is_bool (x
))
211 return class_boolean
;
212 else if (scm_is_null (x
))
215 return class_unknown
;
218 switch (SCM_TYP7 (x
))
220 case scm_tcs_cons_nimcar
:
227 case scm_tc7_pointer
:
228 return class_foreign
;
229 case scm_tc7_hashtable
:
230 return class_hashtable
;
233 case scm_tc7_dynamic_state
:
234 return class_dynamic_state
;
237 case scm_tc7_keyword
:
238 return class_keyword
;
239 case scm_tc7_vm_cont
:
240 return class_vm_cont
;
241 case scm_tc7_bytevector
:
242 if (SCM_BYTEVECTOR_ELEMENT_TYPE (x
) == SCM_ARRAY_ELEMENT_TYPE_VU8
)
243 return class_bytevector
;
248 case scm_tc7_bitvector
:
249 return class_bitvector
;
253 switch SCM_TYP16 (x
) {
255 return class_integer
;
258 case scm_tc16_complex
:
259 return class_complex
;
260 case scm_tc16_fraction
:
261 return class_fraction
;
263 case scm_tc7_program
:
264 if (SCM_PROGRAM_IS_PRIMITIVE_GENERIC (x
)
265 && SCM_UNPACK (*SCM_SUBR_GENERIC (x
)))
266 return class_primitive_generic
;
268 return class_procedure
;
272 scm_t_bits type
= SCM_TYP16 (x
);
273 if (type
!= scm_tc16_port_with_ps
)
274 return scm_i_smob_class
[SCM_TC2SMOBNUM (type
)];
275 x
= SCM_PORT_WITH_PS_PORT (x
);
276 /* fall through to ports */
279 return scm_i_port_class
[(SCM_WRTNG
& SCM_CELL_WORD_0 (x
)
280 ? (SCM_RDNG
& SCM_CELL_WORD_0 (x
)
281 ? SCM_INOUT_PCLASS_INDEX
| SCM_PTOBNUM (x
)
282 : SCM_OUT_PCLASS_INDEX
| SCM_PTOBNUM (x
))
283 : SCM_IN_PCLASS_INDEX
| SCM_PTOBNUM (x
))];
285 if (SCM_OBJ_CLASS_FLAGS (x
) & SCM_CLASSF_GOOPS_VALID
)
286 /* A GOOPS object with a valid class. */
287 return SCM_CLASS_OF (x
);
288 else if (SCM_OBJ_CLASS_FLAGS (x
) & SCM_CLASSF_GOOPS
)
289 /* A GOOPS object whose class might have been redefined. */
291 SCM
class = SCM_CLASS_OF (x
);
292 SCM new_class
= scm_slot_ref (class, sym_redefined
);
293 if (!scm_is_false (new_class
))
294 scm_change_object_class (x
, class, new_class
);
295 /* Re-load class from instance. */
296 return SCM_CLASS_OF (x
);
299 return scm_i_define_class_for_vtable (SCM_CLASS_OF (x
));
304 return class_unknown
;
310 /* case scm_tc3_unused: */
314 return class_unknown
;
321 SCM_DEFINE (scm_instance_p
, "instance?", 1, 0, 0,
323 "Return @code{#t} if @var{obj} is an instance.")
324 #define FUNC_NAME s_scm_instance_p
326 return scm_from_bool (SCM_INSTANCEP (obj
));
331 scm_is_generic (SCM x
)
333 return SCM_INSTANCEP (x
) && SCM_SUBCLASSP (SCM_CLASS_OF (x
), class_generic
);
337 scm_is_method (SCM x
)
339 return SCM_INSTANCEP (x
) && SCM_SUBCLASSP (SCM_CLASS_OF (x
), class_method
);
346 scm_class_name (SCM obj
)
348 return scm_call_1 (scm_variable_ref (var_class_name
), obj
);
352 scm_class_direct_supers (SCM obj
)
354 return scm_call_1 (scm_variable_ref (var_class_direct_supers
), obj
);
358 scm_class_direct_slots (SCM obj
)
360 return scm_call_1 (scm_variable_ref (var_class_direct_slots
), obj
);
364 scm_class_direct_subclasses (SCM obj
)
366 return scm_call_1 (scm_variable_ref (var_class_direct_subclasses
), obj
);
370 scm_class_direct_methods (SCM obj
)
372 return scm_call_1 (scm_variable_ref (var_class_direct_methods
), obj
);
376 scm_class_precedence_list (SCM obj
)
378 return scm_call_1 (scm_variable_ref (var_class_precedence_list
), obj
);
382 scm_class_slots (SCM obj
)
384 return scm_call_1 (scm_variable_ref (var_class_slots
), obj
);
390 SCM_DEFINE (scm_generic_function_name
, "generic-function-name", 1, 0, 0,
392 "Return the name of the generic function @var{obj}.")
393 #define FUNC_NAME s_scm_generic_function_name
395 SCM_VALIDATE_GENERIC (1, obj
);
396 return scm_procedure_property (obj
, scm_sym_name
);
401 scm_generic_function_methods (SCM obj
)
403 return scm_call_1 (scm_variable_ref (var_generic_function_methods
), obj
);
407 scm_method_generic_function (SCM obj
)
409 return scm_call_1 (scm_variable_ref (var_method_generic_function
), obj
);
413 scm_method_specializers (SCM obj
)
415 return scm_call_1 (scm_variable_ref (var_method_specializers
), obj
);
419 scm_method_procedure (SCM obj
)
421 return scm_call_1 (scm_variable_ref (var_method_procedure
), obj
);
428 scm_slot_ref (SCM obj
, SCM slot_name
)
430 return scm_call_2 (scm_variable_ref (var_slot_ref
), obj
, slot_name
);
434 scm_slot_set_x (SCM obj
, SCM slot_name
, SCM value
)
436 return scm_call_3 (scm_variable_ref (var_slot_set_x
), obj
, slot_name
, value
);
440 scm_slot_bound_p (SCM obj
, SCM slot_name
)
442 return scm_call_2 (scm_variable_ref (var_slot_bound_p
), obj
, slot_name
);
446 scm_slot_exists_p (SCM obj
, SCM slot_name
)
448 return scm_call_2 (scm_variable_ref (var_slot_exists_p
), obj
, slot_name
);
454 SCM_DEFINE (scm_sys_clear_fields_x
, "%clear-fields!", 2, 0, 0,
455 (SCM obj
, SCM unbound
),
457 #define FUNC_NAME s_scm_sys_clear_fields_x
459 scm_t_signed_bits n
, i
;
462 SCM_VALIDATE_STRUCT (1, obj
);
463 vtable
= SCM_STRUCT_VTABLE (obj
);
465 n
= SCM_STRUCT_DATA_REF (vtable
, scm_vtable_index_size
);
466 layout
= SCM_VTABLE_LAYOUT (vtable
);
468 /* Set all SCM-holding slots to the GOOPS unbound value. */
469 for (i
= 0; i
< n
; i
++)
470 if (scm_i_symbol_ref (layout
, i
*2) == 'p')
471 SCM_STRUCT_SLOT_SET (obj
, i
, unbound
);
473 return SCM_UNSPECIFIED
;
480 SCM_DEFINE (scm_sys_modify_instance
, "%modify-instance", 2, 0, 0,
482 "Used by change-class to modify objects in place.")
483 #define FUNC_NAME s_scm_sys_modify_instance
485 SCM_VALIDATE_INSTANCE (1, old
);
486 SCM_VALIDATE_INSTANCE (2, new);
488 /* Exchange the data contained in old and new. We exchange rather than
489 * scratch the old value with new to be correct with GC.
490 * See "Class redefinition protocol above".
492 SCM_CRITICAL_SECTION_START
;
494 scm_t_bits word0
, word1
;
495 word0
= SCM_CELL_WORD_0 (old
);
496 word1
= SCM_CELL_WORD_1 (old
);
497 SCM_SET_CELL_WORD_0 (old
, SCM_CELL_WORD_0 (new));
498 SCM_SET_CELL_WORD_1 (old
, SCM_CELL_WORD_1 (new));
499 SCM_SET_CELL_WORD_0 (new, word0
);
500 SCM_SET_CELL_WORD_1 (new, word1
);
502 SCM_CRITICAL_SECTION_END
;
503 return SCM_UNSPECIFIED
;
507 SCM_DEFINE (scm_sys_modify_class
, "%modify-class", 2, 0, 0,
510 #define FUNC_NAME s_scm_sys_modify_class
512 SCM_VALIDATE_CLASS (1, old
);
513 SCM_VALIDATE_CLASS (2, new);
515 SCM_CRITICAL_SECTION_START
;
517 scm_t_bits word0
, word1
;
518 word0
= SCM_CELL_WORD_0 (old
);
519 word1
= SCM_CELL_WORD_1 (old
);
520 SCM_SET_CELL_WORD_0 (old
, SCM_CELL_WORD_0 (new));
521 SCM_SET_CELL_WORD_1 (old
, SCM_CELL_WORD_1 (new));
522 SCM_STRUCT_DATA (old
)[scm_vtable_index_self
] = SCM_UNPACK (old
);
523 SCM_SET_CELL_WORD_0 (new, word0
);
524 SCM_SET_CELL_WORD_1 (new, word1
);
525 SCM_STRUCT_DATA (new)[scm_vtable_index_self
] = SCM_UNPACK (new);
527 SCM_CRITICAL_SECTION_END
;
528 return SCM_UNSPECIFIED
;
532 /* When instances change class, they finally get a new body, but
533 * before that, they go through purgatory in hell. Odd as it may
534 * seem, this data structure saves us from eternal suffering in
535 * infinite recursions.
538 static scm_t_bits
**hell
;
539 static long n_hell
= 1; /* one place for the evil one himself */
540 static long hell_size
= 4;
541 static SCM hell_mutex
;
547 for (i
= 1; i
< n_hell
; ++i
)
548 if (SCM_STRUCT_DATA (o
) == hell
[i
])
557 scm_lock_mutex (hell_mutex
);
558 if (n_hell
>= hell_size
)
561 hell
= scm_realloc (hell
, hell_size
* sizeof(*hell
));
563 hell
[n_hell
++] = SCM_STRUCT_DATA (obj
);
564 scm_unlock_mutex (hell_mutex
);
568 go_to_heaven (void *o
)
571 scm_lock_mutex (hell_mutex
);
572 hell
[burnin (obj
)] = hell
[--n_hell
];
573 scm_unlock_mutex (hell_mutex
);
578 purgatory (SCM obj
, SCM new_class
)
580 return scm_call_2 (SCM_VARIABLE_REF (var_change_class
), obj
, new_class
);
583 /* This function calls the generic function change-class for all
584 * instances which aren't currently undergoing class change.
588 scm_change_object_class (SCM obj
, SCM old_class SCM_UNUSED
, SCM new_class
)
592 scm_dynwind_begin (SCM_F_DYNWIND_REWINDABLE
);
593 scm_dynwind_rewind_handler (go_to_hell
, &obj
, SCM_F_WIND_EXPLICITLY
);
594 scm_dynwind_unwind_handler (go_to_heaven
, &obj
, SCM_F_WIND_EXPLICITLY
);
595 purgatory (obj
, new_class
);
603 /* Primitive generics: primitives that can dispatch to generics if their
604 arguments fail to apply. */
606 SCM_DEFINE (scm_generic_capability_p
, "generic-capability?", 1, 0, 0,
609 #define FUNC_NAME s_scm_generic_capability_p
611 SCM_ASSERT (scm_is_true (scm_procedure_p (proc
)),
612 proc
, SCM_ARG1
, FUNC_NAME
);
613 return (SCM_PRIMITIVE_GENERIC_P (proc
) ? SCM_BOOL_T
: SCM_BOOL_F
);
617 SCM_DEFINE (scm_enable_primitive_generic_x
, "enable-primitive-generic!", 0, 0, 1,
620 #define FUNC_NAME s_scm_enable_primitive_generic_x
622 SCM_VALIDATE_REST_ARGUMENT (subrs
);
623 while (!scm_is_null (subrs
))
625 SCM subr
= SCM_CAR (subrs
);
626 SCM_ASSERT (SCM_PRIMITIVE_GENERIC_P (subr
), subr
, SCM_ARGn
, FUNC_NAME
);
627 SCM_SET_SUBR_GENERIC (subr
,
628 scm_make (scm_list_3 (class_generic
,
630 SCM_SUBR_NAME (subr
))));
631 subrs
= SCM_CDR (subrs
);
633 return SCM_UNSPECIFIED
;
637 SCM_DEFINE (scm_set_primitive_generic_x
, "set-primitive-generic!", 2, 0, 0,
638 (SCM subr
, SCM generic
),
640 #define FUNC_NAME s_scm_set_primitive_generic_x
642 SCM_ASSERT (SCM_PRIMITIVE_GENERIC_P (subr
), subr
, SCM_ARG1
, FUNC_NAME
);
643 SCM_ASSERT (SCM_GENERICP (generic
), generic
, SCM_ARG2
, FUNC_NAME
);
644 SCM_SET_SUBR_GENERIC (subr
, generic
);
645 return SCM_UNSPECIFIED
;
649 SCM_DEFINE (scm_primitive_generic_generic
, "primitive-generic-generic", 1, 0, 0,
652 #define FUNC_NAME s_scm_primitive_generic_generic
654 if (SCM_PRIMITIVE_GENERIC_P (subr
))
656 if (!SCM_UNPACK (*SCM_SUBR_GENERIC (subr
)))
657 scm_enable_primitive_generic_x (scm_list_1 (subr
));
658 return *SCM_SUBR_GENERIC (subr
);
660 SCM_WRONG_TYPE_ARG (SCM_ARG1
, subr
);
665 scm_wta_dispatch_0 (SCM gf
, const char *subr
)
667 if (!SCM_UNPACK (gf
))
668 scm_error_num_args_subr (subr
);
670 return scm_call_0 (gf
);
674 scm_wta_dispatch_1 (SCM gf
, SCM a1
, int pos
, const char *subr
)
676 if (!SCM_UNPACK (gf
))
677 scm_wrong_type_arg (subr
, pos
, a1
);
679 return scm_call_1 (gf
, a1
);
683 scm_wta_dispatch_2 (SCM gf
, SCM a1
, SCM a2
, int pos
, const char *subr
)
685 if (!SCM_UNPACK (gf
))
686 scm_wrong_type_arg (subr
, pos
, (pos
== SCM_ARG1
) ? a1
: a2
);
688 return scm_call_2 (gf
, a1
, a2
);
692 scm_wta_dispatch_n (SCM gf
, SCM args
, int pos
, const char *subr
)
694 if (!SCM_UNPACK (gf
))
695 scm_wrong_type_arg (subr
, pos
, scm_list_ref (args
, scm_from_int (pos
)));
697 return scm_apply_0 (gf
, args
);
706 return scm_apply_0 (scm_variable_ref (var_make
), args
);
712 /* SMOB, struct, and port classes. */
715 make_class_name (const char *prefix
, const char *type_name
, const char *suffix
)
719 return scm_string_to_symbol (scm_string_append
720 (scm_list_3 (scm_from_utf8_string (prefix
),
721 scm_from_utf8_string (type_name
),
722 scm_from_utf8_string (suffix
))));
726 scm_make_extended_class (char const *type_name
, int applicablep
)
728 SCM name
, meta
, supers
;
730 name
= make_class_name ("<", type_name
, ">");
734 supers
= scm_list_1 (class_applicable
);
736 supers
= scm_list_1 (class_top
);
738 return scm_make_standard_class (meta
, name
, supers
, SCM_EOL
);
742 scm_i_inherit_applicable (SCM c
)
744 scm_call_1 (scm_variable_ref (var_inherit_applicable
), c
);
748 create_smob_classes (void)
752 for (i
= 0; i
< SCM_I_MAX_SMOB_TYPE_COUNT
; ++i
)
753 scm_i_smob_class
[i
] = SCM_BOOL_F
;
755 for (i
= 0; i
< scm_numsmob
; ++i
)
756 if (scm_is_false (scm_i_smob_class
[i
]))
757 scm_i_smob_class
[i
] = scm_make_extended_class (SCM_SMOBNAME (i
),
758 scm_smobs
[i
].apply
!= 0);
762 scm_make_port_classes (long ptobnum
, char *type_name
)
764 SCM name
, meta
, super
, supers
;
768 name
= make_class_name ("<", type_name
, "-port>");
769 supers
= scm_list_1 (class_port
);
770 super
= scm_make_standard_class (meta
, name
, supers
, SCM_EOL
);
772 name
= make_class_name ("<", type_name
, "-input-port>");
773 supers
= scm_list_2 (super
, class_input_port
);
774 scm_i_port_class
[SCM_IN_PCLASS_INDEX
+ ptobnum
]
775 = scm_make_standard_class (meta
, name
, supers
, SCM_EOL
);
777 name
= make_class_name ("<", type_name
, "-output-port>");
778 supers
= scm_list_2 (super
, class_output_port
);
779 scm_i_port_class
[SCM_OUT_PCLASS_INDEX
+ ptobnum
]
780 = scm_make_standard_class (meta
, name
, supers
, SCM_EOL
);
782 name
= make_class_name ("<", type_name
, "-input-output-port>");
783 supers
= scm_list_2 (super
, class_input_output_port
);
784 scm_i_port_class
[SCM_INOUT_PCLASS_INDEX
+ ptobnum
]
785 = scm_make_standard_class (meta
, name
, supers
, SCM_EOL
);
789 create_port_classes (void)
793 for (i
= scm_c_num_port_types () - 1; i
>= 0; i
--)
794 scm_make_port_classes (i
, SCM_PTOBNAME (i
));
798 scm_i_define_class_for_vtable (SCM vtable
)
802 scm_i_pthread_mutex_lock (&scm_i_misc_mutex
);
803 if (scm_is_false (vtable_class_map
))
804 vtable_class_map
= scm_c_make_weak_table (0, SCM_WEAK_TABLE_KIND_KEY
);
805 scm_i_pthread_mutex_unlock (&scm_i_misc_mutex
);
807 if (scm_is_false (scm_struct_vtable_p (vtable
)))
810 class = scm_weak_table_refq (vtable_class_map
, vtable
, SCM_BOOL_F
);
812 if (scm_is_false (class))
814 if (SCM_UNPACK (class_class
))
816 SCM name
, meta
, supers
;
818 name
= SCM_VTABLE_NAME (vtable
);
819 if (scm_is_symbol (name
))
820 name
= scm_string_to_symbol
822 (scm_list_3 (scm_from_latin1_string ("<"),
823 scm_symbol_to_string (name
),
824 scm_from_latin1_string (">"))));
826 name
= scm_from_latin1_symbol ("<>");
828 if (SCM_STRUCT_VTABLE_FLAG_IS_SET (vtable
, SCM_VTABLE_FLAG_SETTER
))
830 meta
= class_applicable_struct_with_setter_class
;
831 supers
= scm_list_1 (class_applicable_struct_with_setter
);
833 else if (SCM_STRUCT_VTABLE_FLAG_IS_SET (vtable
,
834 SCM_VTABLE_FLAG_APPLICABLE
))
836 meta
= class_applicable_struct_class
;
837 supers
= scm_list_1 (class_applicable_struct
);
842 supers
= scm_list_1 (class_top
);
845 return scm_make_standard_class (meta
, name
, supers
, SCM_EOL
);
848 /* `create_struct_classes' will fill this in later. */
851 /* Don't worry about races. This only happens when creating a
852 vtable, which happens by definition in one thread. */
853 scm_weak_table_putq_x (vtable_class_map
, vtable
, class);
860 make_struct_class (void *closure SCM_UNUSED
,
861 SCM vtable
, SCM data
, SCM prev SCM_UNUSED
)
863 if (scm_is_false (data
))
864 scm_i_define_class_for_vtable (vtable
);
865 return SCM_UNSPECIFIED
;
869 create_struct_classes (void)
871 /* FIXME: take the vtable_class_map while initializing goops? */
872 scm_internal_hash_fold (make_struct_class
, 0, SCM_BOOL_F
,
883 scm_c_resolve_module ("oop goops");
887 scm_ensure_accessor (SCM name
)
891 var
= scm_module_variable (scm_current_module (), name
);
892 if (SCM_VARIABLEP (var
) && !SCM_UNBNDP (SCM_VARIABLE_REF (var
)))
893 gf
= SCM_VARIABLE_REF (var
);
897 if (!SCM_IS_A_P (gf
, class_accessor
))
899 gf
= scm_make (scm_list_3 (class_generic
, k_name
, name
));
900 gf
= scm_make (scm_list_5 (class_accessor
,
901 k_name
, name
, k_setter
, gf
));
910 SCM_DEFINE (scm_sys_goops_early_init
, "%goops-early-init", 0, 0, 0,
913 #define FUNC_NAME s_scm_sys_goops_early_init
915 var_make_standard_class
= scm_c_lookup ("make-standard-class");
916 var_make
= scm_c_lookup ("make");
917 var_inherit_applicable
= scm_c_lookup ("inherit-applicable!");
919 /* For SCM_SUBCLASSP. */
920 var_class_precedence_list
= scm_c_lookup ("class-precedence-list");
922 var_slot_ref
= scm_c_lookup ("slot-ref");
923 var_slot_set_x
= scm_c_lookup ("slot-set!");
924 var_slot_bound_p
= scm_c_lookup ("slot-bound?");
925 var_slot_exists_p
= scm_c_lookup ("slot-exists?");
927 class_class
= scm_variable_ref (scm_c_lookup ("<class>"));
928 class_top
= scm_variable_ref (scm_c_lookup ("<top>"));
929 class_object
= scm_variable_ref (scm_c_lookup ("<object>"));
931 class_foreign_slot
= scm_variable_ref (scm_c_lookup ("<foreign-slot>"));
932 class_protected
= scm_variable_ref (scm_c_lookup ("<protected-slot>"));
933 class_hidden
= scm_variable_ref (scm_c_lookup ("<hidden-slot>"));
934 class_opaque
= scm_variable_ref (scm_c_lookup ("<opaque-slot>"));
935 class_read_only
= scm_variable_ref (scm_c_lookup ("<read-only-slot>"));
936 class_self
= scm_variable_ref (scm_c_lookup ("<self-slot>"));
937 class_protected_opaque
= scm_variable_ref (scm_c_lookup ("<protected-opaque-slot>"));
938 class_protected_hidden
= scm_variable_ref (scm_c_lookup ("<protected-hidden-slot>"));
939 class_protected_read_only
= scm_variable_ref (scm_c_lookup ("<protected-read-only-slot>"));
940 class_scm
= scm_variable_ref (scm_c_lookup ("<scm-slot>"));
941 class_int
= scm_variable_ref (scm_c_lookup ("<int-slot>"));
942 class_float
= scm_variable_ref (scm_c_lookup ("<float-slot>"));
943 class_double
= scm_variable_ref (scm_c_lookup ("<double-slot>"));
946 class_procedure_class
= scm_variable_ref (scm_c_lookup ("<procedure-class>"));
947 class_applicable_struct_class
= scm_variable_ref (scm_c_lookup ("<applicable-struct-class>"));
948 class_applicable_struct_with_setter_class
=
949 scm_variable_ref (scm_c_lookup ("<applicable-struct-with-setter-class>"));
951 class_method
= scm_variable_ref (scm_c_lookup ("<method>"));
952 class_accessor_method
= scm_variable_ref (scm_c_lookup ("<accessor-method>"));
953 class_applicable
= scm_variable_ref (scm_c_lookup ("<applicable>"));
954 class_applicable_struct
= scm_variable_ref (scm_c_lookup ("<applicable-struct>"));
955 class_applicable_struct_with_setter
= scm_variable_ref (scm_c_lookup ("<applicable-struct-with-setter>"));
956 class_generic
= scm_variable_ref (scm_c_lookup ("<generic>"));
957 class_extended_generic
= scm_variable_ref (scm_c_lookup ("<extended-generic>"));
958 class_generic_with_setter
= scm_variable_ref (scm_c_lookup ("<generic-with-setter>"));
959 class_accessor
= scm_variable_ref (scm_c_lookup ("<accessor>"));
960 class_extended_generic_with_setter
= scm_variable_ref (scm_c_lookup ("<extended-generic-with-setter>"));
961 class_extended_accessor
= scm_variable_ref (scm_c_lookup ("<extended-accessor>"));
963 /* Primitive types classes */
964 class_boolean
= scm_variable_ref (scm_c_lookup ("<boolean>"));
965 class_char
= scm_variable_ref (scm_c_lookup ("<char>"));
966 class_list
= scm_variable_ref (scm_c_lookup ("<list>"));
967 class_pair
= scm_variable_ref (scm_c_lookup ("<pair>"));
968 class_null
= scm_variable_ref (scm_c_lookup ("<null>"));
969 class_string
= scm_variable_ref (scm_c_lookup ("<string>"));
970 class_symbol
= scm_variable_ref (scm_c_lookup ("<symbol>"));
971 class_vector
= scm_variable_ref (scm_c_lookup ("<vector>"));
972 class_foreign
= scm_variable_ref (scm_c_lookup ("<foreign>"));
973 class_hashtable
= scm_variable_ref (scm_c_lookup ("<hashtable>"));
974 class_fluid
= scm_variable_ref (scm_c_lookup ("<fluid>"));
975 class_dynamic_state
= scm_variable_ref (scm_c_lookup ("<dynamic-state>"));
976 class_frame
= scm_variable_ref (scm_c_lookup ("<frame>"));
977 class_keyword
= scm_variable_ref (scm_c_lookup ("<keyword>"));
978 class_vm_cont
= scm_variable_ref (scm_c_lookup ("<vm-continuation>"));
979 class_bytevector
= scm_variable_ref (scm_c_lookup ("<bytevector>"));
980 class_uvec
= scm_variable_ref (scm_c_lookup ("<uvec>"));
981 class_array
= scm_variable_ref (scm_c_lookup ("<array>"));
982 class_bitvector
= scm_variable_ref (scm_c_lookup ("<bitvector>"));
983 class_number
= scm_variable_ref (scm_c_lookup ("<number>"));
984 class_complex
= scm_variable_ref (scm_c_lookup ("<complex>"));
985 class_real
= scm_variable_ref (scm_c_lookup ("<real>"));
986 class_integer
= scm_variable_ref (scm_c_lookup ("<integer>"));
987 class_fraction
= scm_variable_ref (scm_c_lookup ("<fraction>"));
988 class_keyword
= scm_variable_ref (scm_c_lookup ("<keyword>"));
989 class_unknown
= scm_variable_ref (scm_c_lookup ("<unknown>"));
990 class_procedure
= scm_variable_ref (scm_c_lookup ("<procedure>"));
991 class_primitive_generic
= scm_variable_ref (scm_c_lookup ("<primitive-generic>"));
992 class_port
= scm_variable_ref (scm_c_lookup ("<port>"));
993 class_input_port
= scm_variable_ref (scm_c_lookup ("<input-port>"));
994 class_output_port
= scm_variable_ref (scm_c_lookup ("<output-port>"));
995 class_input_output_port
= scm_variable_ref (scm_c_lookup ("<input-output-port>"));
997 create_smob_classes ();
998 create_struct_classes ();
999 create_port_classes ();
1001 return SCM_UNSPECIFIED
;
1005 SCM_DEFINE (scm_sys_goops_loaded
, "%goops-loaded", 0, 0, 0,
1007 "Announce that GOOPS is loaded and perform initialization\n"
1008 "on the C level which depends on the loaded GOOPS modules.")
1009 #define FUNC_NAME s_scm_sys_goops_loaded
1012 var_class_name
= scm_c_lookup ("class-name");
1013 var_class_direct_supers
= scm_c_lookup ("class-direct-supers");
1014 var_class_direct_slots
= scm_c_lookup ("class-direct-slots");
1015 var_class_direct_subclasses
= scm_c_lookup ("class-direct-subclasses");
1016 var_class_direct_methods
= scm_c_lookup ("class-direct-methods");
1017 var_class_slots
= scm_c_lookup ("class-slots");
1019 var_generic_function_methods
= scm_c_lookup ("generic-function-methods");
1020 var_method_generic_function
= scm_c_lookup ("method-generic-function");
1021 var_method_specializers
= scm_c_lookup ("method-specializers");
1022 var_method_procedure
= scm_c_lookup ("method-procedure");
1024 var_change_class
= scm_c_lookup ("change-class");
1026 #if (SCM_ENABLE_DEPRECATED == 1)
1027 scm_init_deprecated_goops ();
1030 return SCM_UNSPECIFIED
;
1035 scm_init_goops_builtins (void *unused
)
1037 scm_module_goops
= scm_current_module ();
1039 hell
= scm_calloc (hell_size
* sizeof (*hell
));
1040 hell_mutex
= scm_make_mutex ();
1042 #include "libguile/goops.x"
1044 scm_c_define ("vtable-flag-vtable",
1045 scm_from_int (SCM_VTABLE_FLAG_VTABLE
));
1046 scm_c_define ("vtable-flag-applicable-vtable",
1047 scm_from_int (SCM_VTABLE_FLAG_APPLICABLE_VTABLE
));
1048 scm_c_define ("vtable-flag-setter-vtable",
1049 scm_from_int (SCM_VTABLE_FLAG_SETTER_VTABLE
));
1050 scm_c_define ("vtable-flag-validated",
1051 scm_from_int (SCM_VTABLE_FLAG_VALIDATED
));
1052 scm_c_define ("vtable-flag-goops-class",
1053 scm_from_int (SCM_VTABLE_FLAG_GOOPS_CLASS
));
1054 scm_c_define ("vtable-flag-goops-valid",
1055 scm_from_int (SCM_VTABLE_FLAG_GOOPS_VALID
));
1056 scm_c_define ("vtable-flag-goops-slot",
1057 scm_from_int (SCM_VTABLE_FLAG_GOOPS_SLOT
));
1063 scm_c_register_extension ("libguile-" SCM_EFFECTIVE_VERSION
,
1064 "scm_init_goops_builtins", scm_init_goops_builtins
,