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>.
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/gsubr.h"
43 #include "libguile/hashtab.h"
44 #include "libguile/keywords.h"
45 #include "libguile/macros.h"
46 #include "libguile/modules.h"
47 #include "libguile/ports.h"
48 #include "libguile/procprop.h"
49 #include "libguile/programs.h"
50 #include "libguile/random.h"
51 #include "libguile/root.h"
52 #include "libguile/smob.h"
53 #include "libguile/strings.h"
54 #include "libguile/strports.h"
55 #include "libguile/vectors.h"
56 #include "libguile/vm.h"
58 #include "libguile/validate.h"
59 #include "libguile/goops.h"
62 #define SCM_IN_PCLASS_INDEX 0
63 #define SCM_OUT_PCLASS_INDEX SCM_I_MAX_PORT_TYPE_COUNT
64 #define SCM_INOUT_PCLASS_INDEX (2 * SCM_I_MAX_PORT_TYPE_COUNT)
66 /* this file is a mess. in theory, though, we shouldn't have many SCM references
67 -- most of the references should be to vars. */
69 static SCM var_slot_unbound
= SCM_BOOL_F
;
70 static SCM var_slot_missing
= SCM_BOOL_F
;
71 static SCM var_compute_cpl
= SCM_BOOL_F
;
72 static SCM var_no_applicable_method
= SCM_BOOL_F
;
73 static SCM var_change_class
= SCM_BOOL_F
;
75 SCM_SYMBOL (sym_slot_unbound
, "slot-unbound");
76 SCM_SYMBOL (sym_slot_missing
, "slot-missing");
77 SCM_SYMBOL (sym_compute_cpl
, "compute-cpl");
78 SCM_SYMBOL (sym_no_applicable_method
, "no-applicable-method");
79 SCM_SYMBOL (sym_memoize_method_x
, "memoize-method!");
80 SCM_SYMBOL (sym_change_class
, "change-class");
82 SCM_VARIABLE (scm_var_make_extended_generic
, "make-extended-generic");
85 /* Class redefinition protocol:
87 A class is represented by a heap header h1 which points to a
88 malloc:ed memory block m1.
90 When a new version of a class is created, a new header h2 and
91 memory block m2 are allocated. The headers h1 and h2 then switch
92 pointers so that h1 refers to m2 and h2 to m1. In this way, names
93 bound to h1 will point to the new class at the same time as h2 will
94 be a handle which the GC will use to free m1.
96 The `redefined' slot of m1 will be set to point to h1. An old
97 instance will have its class pointer (the CAR of the heap header)
98 pointing to m1. The non-immediate `redefined'-slot in m1 indicates
99 the class modification and the new class pointer can be found via
103 #define TEST_CHANGE_CLASS(obj, class) \
105 class = SCM_CLASS_OF (obj); \
106 if (scm_is_true (SCM_OBJ_CLASS_REDEF (obj))) \
108 scm_change_object_class (obj, class, SCM_OBJ_CLASS_REDEF (obj));\
109 class = SCM_CLASS_OF (obj); \
113 #define SCM_GOOPS_UNBOUND SCM_UNBOUND
114 #define SCM_GOOPS_UNBOUNDP(x) (scm_is_eq (x, SCM_GOOPS_UNBOUND))
116 static int goops_loaded_p
= 0;
117 static scm_t_rstate
*goops_rstate
;
119 /* These variables are filled in by the object system when loaded. */
120 SCM scm_class_boolean
, scm_class_char
, scm_class_pair
;
121 SCM scm_class_procedure
, scm_class_string
, scm_class_symbol
;
122 SCM scm_class_primitive_generic
;
123 SCM scm_class_vector
, scm_class_null
;
124 SCM scm_class_integer
, scm_class_real
, scm_class_complex
, scm_class_fraction
;
125 SCM scm_class_unknown
;
126 SCM scm_class_top
, scm_class_object
, scm_class_class
;
127 SCM scm_class_applicable
;
128 SCM scm_class_applicable_struct
, scm_class_applicable_struct_with_setter
;
129 SCM scm_class_generic
, scm_class_generic_with_setter
;
130 SCM scm_class_accessor
;
131 SCM scm_class_extended_generic
, scm_class_extended_generic_with_setter
;
132 SCM scm_class_extended_accessor
;
133 SCM scm_class_method
;
134 SCM scm_class_accessor_method
;
135 SCM scm_class_procedure_class
;
136 SCM scm_class_applicable_struct_class
;
137 SCM scm_class_number
, scm_class_list
;
138 SCM scm_class_keyword
;
139 SCM scm_class_port
, scm_class_input_output_port
;
140 SCM scm_class_input_port
, scm_class_output_port
;
141 SCM scm_class_foreign_slot
;
142 SCM scm_class_self
, scm_class_protected
;
143 SCM scm_class_hidden
, scm_class_opaque
, scm_class_read_only
;
144 SCM scm_class_protected_hidden
, scm_class_protected_opaque
, scm_class_protected_read_only
;
146 SCM scm_class_int
, scm_class_float
, scm_class_double
;
148 static SCM class_foreign
;
149 static SCM class_hashtable
;
150 static SCM class_fluid
;
151 static SCM class_dynamic_state
;
152 static SCM class_frame
;
153 static SCM class_vm_cont
;
154 static SCM class_bytevector
;
155 static SCM class_uvec
;
156 static SCM class_array
;
157 static SCM class_bitvector
;
159 static SCM vtable_class_map
= SCM_BOOL_F
;
161 /* Port classes. Allocate 3 times the maximum number of port types so that
162 input ports, output ports, and in/out ports can be stored at different
163 offsets. See `SCM_IN_PCLASS_INDEX' et al. */
164 SCM scm_port_class
[3 * SCM_I_MAX_PORT_TYPE_COUNT
];
167 SCM scm_smob_class
[SCM_I_MAX_SMOB_TYPE_COUNT
];
169 SCM scm_no_applicable_method
;
171 static SCM
scm_make_unbound (void);
172 static SCM
scm_unbound_p (SCM obj
);
173 static SCM
scm_assert_bound (SCM value
, SCM obj
);
174 static SCM
scm_at_assert_bound_ref (SCM obj
, SCM index
);
175 static SCM
scm_sys_goops_early_init (void);
176 static SCM
scm_sys_goops_loaded (void);
177 static SCM
scm_make_extended_class_from_symbol (SCM type_name_sym
,
182 scm_i_define_class_for_vtable (SCM vtable
)
186 scm_i_pthread_mutex_lock (&scm_i_misc_mutex
);
187 if (scm_is_false (vtable_class_map
))
188 vtable_class_map
= scm_c_make_weak_table (0, SCM_WEAK_TABLE_KIND_KEY
);
189 scm_i_pthread_mutex_unlock (&scm_i_misc_mutex
);
191 if (scm_is_false (scm_struct_vtable_p (vtable
)))
194 class = scm_weak_table_refq (vtable_class_map
, vtable
, SCM_BOOL_F
);
196 if (scm_is_false (class))
198 if (SCM_UNPACK (scm_class_class
))
200 SCM name
= SCM_VTABLE_NAME (vtable
);
201 if (!scm_is_symbol (name
))
202 name
= scm_string_to_symbol (scm_nullstr
);
204 class = scm_make_extended_class_from_symbol
205 (name
, SCM_VTABLE_FLAG_IS_SET (vtable
, SCM_VTABLE_FLAG_APPLICABLE
));
208 /* `create_struct_classes' will fill this in later. */
211 /* Don't worry about races. This only happens when creating a
212 vtable, which happens by definition in one thread. */
213 scm_weak_table_putq_x (vtable_class_map
, vtable
, class);
219 /* This function is used for efficient type dispatch. */
220 SCM_DEFINE (scm_class_of
, "class-of", 1, 0, 0,
222 "Return the class of @var{x}.")
223 #define FUNC_NAME s_scm_class_of
225 switch (SCM_ITAG3 (x
))
229 return scm_class_integer
;
233 return scm_class_char
;
234 else if (scm_is_bool (x
))
235 return scm_class_boolean
;
236 else if (scm_is_null (x
))
237 return scm_class_null
;
239 return scm_class_unknown
;
242 switch (SCM_TYP7 (x
))
244 case scm_tcs_cons_nimcar
:
245 return scm_class_pair
;
247 return scm_class_symbol
;
250 return scm_class_vector
;
251 case scm_tc7_pointer
:
252 return class_foreign
;
253 case scm_tc7_hashtable
:
254 return class_hashtable
;
257 case scm_tc7_dynamic_state
:
258 return class_dynamic_state
;
261 case scm_tc7_keyword
:
262 return scm_class_keyword
;
263 case scm_tc7_vm_cont
:
264 return class_vm_cont
;
265 case scm_tc7_bytevector
:
266 if (SCM_BYTEVECTOR_ELEMENT_TYPE (x
) == SCM_ARRAY_ELEMENT_TYPE_VU8
)
267 return class_bytevector
;
272 case scm_tc7_bitvector
:
273 return class_bitvector
;
275 return scm_class_string
;
277 switch SCM_TYP16 (x
) {
279 return scm_class_integer
;
281 return scm_class_real
;
282 case scm_tc16_complex
:
283 return scm_class_complex
;
284 case scm_tc16_fraction
:
285 return scm_class_fraction
;
287 case scm_tc7_program
:
288 if (SCM_PROGRAM_IS_PRIMITIVE_GENERIC (x
)
289 && SCM_UNPACK (*SCM_SUBR_GENERIC (x
)))
290 return scm_class_primitive_generic
;
292 return scm_class_procedure
;
296 scm_t_bits type
= SCM_TYP16 (x
);
297 if (type
!= scm_tc16_port_with_ps
)
298 return scm_smob_class
[SCM_TC2SMOBNUM (type
)];
299 x
= SCM_PORT_WITH_PS_PORT (x
);
300 /* fall through to ports */
303 return scm_port_class
[(SCM_WRTNG
& SCM_CELL_WORD_0 (x
)
304 ? (SCM_RDNG
& SCM_CELL_WORD_0 (x
)
305 ? SCM_INOUT_PCLASS_INDEX
| SCM_PTOBNUM (x
)
306 : SCM_OUT_PCLASS_INDEX
| SCM_PTOBNUM (x
))
307 : SCM_IN_PCLASS_INDEX
| SCM_PTOBNUM (x
))];
309 if (SCM_OBJ_CLASS_FLAGS (x
) & SCM_CLASSF_GOOPS_VALID
)
310 return SCM_CLASS_OF (x
);
311 else if (SCM_OBJ_CLASS_FLAGS (x
) & SCM_CLASSF_GOOPS
)
314 if (! scm_is_false (SCM_OBJ_CLASS_REDEF (x
)))
315 scm_change_object_class (x
,
316 SCM_CLASS_OF (x
), /* old */
317 SCM_OBJ_CLASS_REDEF (x
)); /* new */
318 return SCM_CLASS_OF (x
);
321 return scm_i_define_class_for_vtable (SCM_CLASS_OF (x
));
324 return scm_class_pair
;
326 return scm_class_unknown
;
332 /* case scm_tc3_unused: */
336 return scm_class_unknown
;
340 /******************************************************************************
344 ******************************************************************************/
347 remove_duplicate_slots (SCM l
, SCM res
, SCM slots_already_seen
)
351 if (!scm_is_pair (l
))
355 if (!scm_is_symbol (tmp
))
356 scm_misc_error ("%compute-slots", "bad slot name ~S", scm_list_1 (tmp
));
358 if (scm_is_false (scm_c_memq (tmp
, slots_already_seen
))) {
359 res
= scm_cons (SCM_CAR (l
), res
);
360 slots_already_seen
= scm_cons (tmp
, slots_already_seen
);
363 return remove_duplicate_slots (SCM_CDR (l
), res
, slots_already_seen
);
367 check_cpl (SCM slots
, SCM bslots
)
369 for (; scm_is_pair (bslots
); bslots
= SCM_CDR (bslots
))
370 if (scm_is_true (scm_assq (SCM_CAAR (bslots
), slots
)))
371 scm_misc_error ("init-object", "a predefined <class> inherited "
372 "field cannot be redefined", SCM_EOL
);
375 enum build_class_class_slots_mode
{ BOOT_SLOTS
, FINAL_SLOTS
};
376 static SCM
build_class_class_slots (enum build_class_class_slots_mode mode
);
379 build_slots_list (SCM dslots
, SCM cpl
)
381 SCM bslots
, class_slots
;
385 class_slots
= SCM_EOL
;
386 classp
= scm_is_true (scm_memq (scm_class_class
, cpl
));
390 bslots
= build_class_class_slots (FINAL_SLOTS
);
391 check_cpl (res
, bslots
);
396 if (scm_is_pair (cpl
))
398 for (cpl
= SCM_CDR (cpl
); scm_is_pair (cpl
); cpl
= SCM_CDR (cpl
))
400 SCM new_slots
= SCM_SLOT (SCM_CAR (cpl
),
401 scm_si_direct_slots
);
404 if (!scm_is_eq (SCM_CAR (cpl
), scm_class_class
))
405 check_cpl (new_slots
, bslots
);
408 /* Move class slots to the head of the list. */
409 class_slots
= new_slots
;
413 res
= scm_append (scm_list_2 (new_slots
, res
));
417 scm_misc_error ("%compute-slots", "malformed cpl argument in "
418 "build_slots_list", SCM_EOL
);
420 /* make sure to add the <class> slots to the head of the list */
422 res
= scm_append (scm_list_2 (class_slots
, res
));
424 /* res contains a list of slots. Remove slots which appears more than once */
425 return remove_duplicate_slots (scm_reverse (res
), SCM_EOL
, SCM_EOL
);
432 while (!scm_is_null (ls
))
434 if (!scm_is_pair (ls
))
435 scm_misc_error ("%compute-slots", "malformed ls argument in "
437 if (!scm_is_pair (SCM_CAR (ls
)))
438 SCM_SETCAR (ls
, scm_cons (SCM_CAR (ls
), SCM_EOL
));
445 SCM_DEFINE (scm_sys_compute_slots
, "%compute-slots", 1, 0, 0,
447 "Return a list consisting of the names of all slots belonging to\n"
448 "class @var{class}, i. e. the slots of @var{class} and of all of\n"
450 #define FUNC_NAME s_scm_sys_compute_slots
452 SCM_VALIDATE_CLASS (1, class);
453 return build_slots_list (SCM_SLOT (class, scm_si_direct_slots
),
454 SCM_SLOT (class, scm_si_cpl
));
459 /******************************************************************************
461 * compute-getters-n-setters
463 * This version doesn't handle slot options. It serves only for booting
464 * classes and will be overloaded in Scheme.
466 ******************************************************************************/
468 SCM_KEYWORD (k_init_value
, "init-value");
469 SCM_KEYWORD (k_init_thunk
, "init-thunk");
472 compute_getters_n_setters (SCM slots
)
478 for ( ; !scm_is_null (slots
); slots
= SCM_CDR (slots
))
480 SCM init
= SCM_BOOL_F
;
481 SCM options
= SCM_CDAR (slots
);
482 if (!scm_is_null (options
))
484 init
= scm_get_keyword (k_init_value
, options
, SCM_PACK (0));
485 if (SCM_UNPACK (init
))
487 init
= scm_primitive_eval (scm_list_3 (scm_sym_lambda
,
489 scm_list_2 (scm_sym_quote
,
493 init
= scm_get_keyword (k_init_thunk
, options
, SCM_BOOL_F
);
495 *cdrloc
= scm_cons (scm_cons (SCM_CAAR (slots
),
497 scm_from_int (i
++))),
499 cdrloc
= SCM_CDRLOC (*cdrloc
);
504 /******************************************************************************
508 ******************************************************************************/
510 /*fixme* Manufacture keywords in advance */
512 scm_i_get_keyword (SCM key
, SCM l
, long len
, SCM default_value
, const char *subr
)
516 for (i
= 0; i
!= len
; i
+= 2)
518 SCM obj
= SCM_CAR (l
);
520 if (!scm_is_keyword (obj
))
521 scm_misc_error (subr
, "bad keyword: ~S", scm_list_1 (obj
));
522 else if (scm_is_eq (obj
, key
))
528 return default_value
;
532 SCM_DEFINE (scm_get_keyword
, "get-keyword", 3, 0, 0,
533 (SCM key
, SCM l
, SCM default_value
),
534 "Determine an associated value for the keyword @var{key} from\n"
535 "the list @var{l}. The list @var{l} has to consist of an even\n"
536 "number of elements, where, starting with the first, every\n"
537 "second element is a keyword, followed by its associated value.\n"
538 "If @var{l} does not hold a value for @var{key}, the value\n"
539 "@var{default_value} is returned.")
540 #define FUNC_NAME s_scm_get_keyword
544 SCM_ASSERT (scm_is_keyword (key
), key
, SCM_ARG1
, FUNC_NAME
);
545 len
= scm_ilength (l
);
546 if (len
< 0 || len
% 2 == 1)
547 scm_misc_error (FUNC_NAME
, "Bad keyword-value list: ~S", scm_list_1 (l
));
549 return scm_i_get_keyword (key
, l
, len
, default_value
, FUNC_NAME
);
554 SCM_KEYWORD (k_init_keyword
, "init-keyword");
556 static SCM
get_slot_value (SCM
class, SCM obj
, SCM slotdef
);
557 static SCM
set_slot_value (SCM
class, SCM obj
, SCM slotdef
, SCM value
);
559 SCM_DEFINE (scm_sys_initialize_object
, "%initialize-object", 2, 0, 0,
560 (SCM obj
, SCM initargs
),
561 "Initialize the object @var{obj} with the given arguments\n"
563 #define FUNC_NAME s_scm_sys_initialize_object
565 SCM tmp
, get_n_set
, slots
;
566 SCM
class = SCM_CLASS_OF (obj
);
569 SCM_VALIDATE_INSTANCE (1, obj
);
570 n_initargs
= scm_ilength (initargs
);
571 SCM_ASSERT ((n_initargs
& 1) == 0, initargs
, SCM_ARG2
, FUNC_NAME
);
573 get_n_set
= SCM_SLOT (class, scm_si_getters_n_setters
);
574 slots
= SCM_SLOT (class, scm_si_slots
);
576 /* See for each slot how it must be initialized */
578 !scm_is_null (slots
);
579 get_n_set
= SCM_CDR (get_n_set
), slots
= SCM_CDR (slots
))
581 SCM slot_name
= SCM_CAR (slots
);
582 SCM slot_value
= SCM_GOOPS_UNBOUND
;
584 if (!scm_is_null (SCM_CDR (slot_name
)))
586 /* This slot admits (perhaps) to be initialized at creation time */
587 long n
= scm_ilength (SCM_CDR (slot_name
));
588 if (n
& 1) /* odd or -1 */
589 SCM_MISC_ERROR ("class contains bogus slot definition: ~S",
590 scm_list_1 (slot_name
));
591 tmp
= scm_i_get_keyword (k_init_keyword
,
596 slot_name
= SCM_CAR (slot_name
);
597 if (SCM_UNPACK (tmp
))
599 /* an initarg was provided for this slot */
600 if (!scm_is_keyword (tmp
))
601 SCM_MISC_ERROR ("initarg must be a keyword. It was ~S",
603 slot_value
= scm_i_get_keyword (tmp
,
611 if (!SCM_GOOPS_UNBOUNDP (slot_value
))
612 /* set slot to provided value */
613 set_slot_value (class, obj
, SCM_CAR (get_n_set
), slot_value
);
616 /* set slot to its :init-form if it exists */
617 tmp
= SCM_CADAR (get_n_set
);
618 if (scm_is_true (tmp
))
619 set_slot_value (class,
630 /* NOTE: The following macros are interdependent with code
631 * in goops.scm:compute-getters-n-setters
633 #define SCM_GNS_INSTANCE_ALLOCATED_P(gns) \
634 (SCM_I_INUMP (SCM_CDDR (gns)) \
635 || (scm_is_pair (SCM_CDDR (gns)) \
636 && scm_is_pair (SCM_CDDDR (gns)) \
637 && scm_is_pair (SCM_CDDDDR (gns))))
638 #define SCM_GNS_INDEX(gns) \
639 (SCM_I_INUMP (SCM_CDDR (gns)) \
640 ? SCM_I_INUM (SCM_CDDR (gns)) \
641 : scm_to_long (SCM_CAR (SCM_CDDDDR (gns))))
642 #define SCM_GNS_SIZE(gns) \
643 (SCM_I_INUMP (SCM_CDDR (gns)) \
645 : scm_to_long (SCM_CADR (SCM_CDDDDR (gns))))
647 SCM_KEYWORD (k_class
, "class");
648 SCM_KEYWORD (k_allocation
, "allocation");
649 SCM_KEYWORD (k_instance
, "instance");
651 SCM_DEFINE (scm_sys_prep_layout_x
, "%prep-layout!", 1, 0, 0,
654 #define FUNC_NAME s_scm_sys_prep_layout_x
656 SCM slots
, getters_n_setters
, nfields
;
657 unsigned long int n
, i
;
661 SCM_VALIDATE_INSTANCE (1, class);
662 slots
= SCM_SLOT (class, scm_si_slots
);
663 getters_n_setters
= SCM_SLOT (class, scm_si_getters_n_setters
);
664 nfields
= SCM_SLOT (class, scm_si_nfields
);
665 if (!SCM_I_INUMP (nfields
) || SCM_I_INUM (nfields
) < 0)
666 SCM_MISC_ERROR ("bad value in nfields slot: ~S",
667 scm_list_1 (nfields
));
668 n
= 2 * SCM_I_INUM (nfields
);
669 if (n
< sizeof (SCM_CLASS_CLASS_LAYOUT
) - 1
670 && SCM_SUBCLASSP (class, scm_class_class
))
671 SCM_MISC_ERROR ("class object doesn't have enough fields: ~S",
672 scm_list_1 (nfields
));
674 layout
= scm_i_make_string (n
, &s
, 0);
676 while (scm_is_pair (getters_n_setters
))
678 if (SCM_GNS_INSTANCE_ALLOCATED_P (SCM_CAR (getters_n_setters
)))
681 int len
, index
, size
;
684 if (i
>= n
|| !scm_is_pair (slots
))
687 /* extract slot type */
688 len
= scm_ilength (SCM_CDAR (slots
));
689 type
= scm_i_get_keyword (k_class
, SCM_CDAR (slots
),
690 len
, SCM_BOOL_F
, FUNC_NAME
);
691 /* determine slot GC protection and access mode */
692 if (scm_is_false (type
))
699 if (!SCM_CLASSP (type
))
700 SCM_MISC_ERROR ("bad slot class", SCM_EOL
);
701 else if (SCM_SUBCLASSP (type
, scm_class_foreign_slot
))
703 if (SCM_SUBCLASSP (type
, scm_class_self
))
705 else if (SCM_SUBCLASSP (type
, scm_class_protected
))
710 if (SCM_SUBCLASSP (type
, scm_class_opaque
))
712 else if (SCM_SUBCLASSP (type
, scm_class_read_only
))
714 else if (SCM_SUBCLASSP (type
, scm_class_hidden
))
726 index
= SCM_GNS_INDEX (SCM_CAR (getters_n_setters
));
727 if (index
!= (i
>> 1))
729 size
= SCM_GNS_SIZE (SCM_CAR (getters_n_setters
));
737 slots
= SCM_CDR (slots
);
738 getters_n_setters
= SCM_CDR (getters_n_setters
);
740 if (!scm_is_null (slots
))
743 SCM_MISC_ERROR ("inconsistent getters-n-setters", SCM_EOL
);
745 SCM_SET_VTABLE_LAYOUT (class, scm_string_to_symbol (layout
));
746 return SCM_UNSPECIFIED
;
750 static void prep_hashsets (SCM
);
752 SCM_DEFINE (scm_sys_inherit_magic_x
, "%inherit-magic!", 2, 0, 0,
753 (SCM
class, SCM dsupers
),
755 #define FUNC_NAME s_scm_sys_inherit_magic_x
757 SCM_VALIDATE_INSTANCE (1, class);
758 scm_i_struct_inherit_vtable_magic (SCM_CLASS_OF (class), class);
759 SCM_SET_CLASS_FLAGS (class, SCM_CLASSF_GOOPS_OR_VALID
);
761 prep_hashsets (class);
763 return SCM_UNSPECIFIED
;
768 prep_hashsets (SCM
class)
772 for (i
= 0; i
< 8; ++i
)
773 SCM_SET_HASHSET (class, i
, scm_c_uniform32 (goops_rstate
));
776 /******************************************************************************/
779 scm_basic_basic_make_class (SCM
class, SCM name
, SCM dsupers
, SCM dslots
)
781 SCM z
, cpl
, slots
, nfields
, g_n_s
;
783 /* Allocate one instance */
784 z
= scm_make_struct (class, SCM_INUM0
, SCM_EOL
);
786 /* Initialize its slots */
787 SCM_SET_SLOT (z
, scm_si_direct_supers
, dsupers
);
788 cpl
= scm_call_1 (SCM_VARIABLE_REF (var_compute_cpl
), z
);
789 slots
= build_slots_list (maplist (dslots
), cpl
);
790 nfields
= scm_from_int (scm_ilength (slots
));
791 g_n_s
= compute_getters_n_setters (slots
);
793 SCM_SET_SLOT (z
, scm_vtable_index_name
, name
);
794 SCM_SET_SLOT (z
, scm_si_direct_slots
, dslots
);
795 SCM_SET_SLOT (z
, scm_si_direct_subclasses
, SCM_EOL
);
796 SCM_SET_SLOT (z
, scm_si_direct_methods
, SCM_EOL
);
797 SCM_SET_SLOT (z
, scm_si_cpl
, cpl
);
798 SCM_SET_SLOT (z
, scm_si_slots
, slots
);
799 SCM_SET_SLOT (z
, scm_si_nfields
, nfields
);
800 SCM_SET_SLOT (z
, scm_si_getters_n_setters
, g_n_s
);
801 SCM_SET_SLOT (z
, scm_si_redefined
, SCM_BOOL_F
);
803 /* Add this class in the direct-subclasses slot of dsupers */
806 for (tmp
= dsupers
; !scm_is_null (tmp
); tmp
= SCM_CDR (tmp
))
807 SCM_SET_SLOT (SCM_CAR (tmp
), scm_si_direct_subclasses
,
808 scm_cons (z
, SCM_SLOT (SCM_CAR (tmp
),
809 scm_si_direct_subclasses
)));
816 scm_basic_make_class (SCM
class, SCM name
, SCM dsupers
, SCM dslots
)
818 SCM z
= scm_basic_basic_make_class (class, name
, dsupers
, dslots
);
819 scm_sys_prep_layout_x (z
);
820 scm_sys_inherit_magic_x (z
, dsupers
);
824 /******************************************************************************/
826 SCM_SYMBOL (sym_layout
, "layout");
827 SCM_SYMBOL (sym_flags
, "flags");
828 SCM_SYMBOL (sym_self
, "%self");
829 SCM_SYMBOL (sym_instance_finalizer
, "instance-finalizer");
830 SCM_SYMBOL (sym_reserved_0
, "%reserved-0");
831 SCM_SYMBOL (sym_reserved_1
, "%reserved-1");
832 SCM_SYMBOL (sym_print
, "print");
833 SCM_SYMBOL (sym_procedure
, "procedure");
834 SCM_SYMBOL (sym_setter
, "setter");
835 SCM_SYMBOL (sym_redefined
, "redefined");
836 SCM_SYMBOL (sym_h0
, "h0");
837 SCM_SYMBOL (sym_h1
, "h1");
838 SCM_SYMBOL (sym_h2
, "h2");
839 SCM_SYMBOL (sym_h3
, "h3");
840 SCM_SYMBOL (sym_h4
, "h4");
841 SCM_SYMBOL (sym_h5
, "h5");
842 SCM_SYMBOL (sym_h6
, "h6");
843 SCM_SYMBOL (sym_h7
, "h7");
844 SCM_SYMBOL (sym_name
, "name");
845 SCM_SYMBOL (sym_direct_supers
, "direct-supers");
846 SCM_SYMBOL (sym_direct_slots
, "direct-slots");
847 SCM_SYMBOL (sym_direct_subclasses
, "direct-subclasses");
848 SCM_SYMBOL (sym_direct_methods
, "direct-methods");
849 SCM_SYMBOL (sym_cpl
, "cpl");
850 SCM_SYMBOL (sym_default_slot_definition_class
, "default-slot-definition-class");
851 SCM_SYMBOL (sym_slots
, "slots");
852 SCM_SYMBOL (sym_getters_n_setters
, "getters-n-setters");
853 SCM_SYMBOL (sym_nfields
, "nfields");
856 static int specialized_slots_initialized
= 0;
859 build_class_class_slots (enum build_class_class_slots_mode mode
)
861 #define SPECIALIZED_SLOT(name, class) \
862 (mode == BOOT_SLOTS ? scm_list_1 (name) : scm_list_3 (name, k_class, class))
864 if (mode
== FINAL_SLOTS
&& !specialized_slots_initialized
)
867 /* has to be kept in sync with SCM_VTABLE_BASE_LAYOUT and
868 SCM_CLASS_CLASS_LAYOUT */
870 SPECIALIZED_SLOT (sym_layout
, scm_class_protected_read_only
),
871 SPECIALIZED_SLOT (sym_flags
, scm_class_hidden
),
872 SPECIALIZED_SLOT (sym_self
, scm_class_self
),
873 SPECIALIZED_SLOT (sym_instance_finalizer
, scm_class_hidden
),
874 scm_list_1 (sym_print
),
875 SPECIALIZED_SLOT (sym_name
, scm_class_protected_hidden
),
876 SPECIALIZED_SLOT (sym_reserved_0
, scm_class_hidden
),
877 SPECIALIZED_SLOT (sym_reserved_1
, scm_class_hidden
),
878 scm_list_1 (sym_redefined
),
879 SPECIALIZED_SLOT (sym_h0
, scm_class_int
),
880 SPECIALIZED_SLOT (sym_h1
, scm_class_int
),
881 SPECIALIZED_SLOT (sym_h2
, scm_class_int
),
882 SPECIALIZED_SLOT (sym_h3
, scm_class_int
),
883 SPECIALIZED_SLOT (sym_h4
, scm_class_int
),
884 SPECIALIZED_SLOT (sym_h5
, scm_class_int
),
885 SPECIALIZED_SLOT (sym_h6
, scm_class_int
),
886 SPECIALIZED_SLOT (sym_h7
, scm_class_int
),
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_nfields
),
900 create_basic_classes (void)
902 SCM slots_of_class
= build_class_class_slots (BOOT_SLOTS
);
905 SCM cs
= scm_from_locale_string (SCM_CLASS_CLASS_LAYOUT
);
906 SCM name
= scm_from_latin1_symbol ("<class>");
907 scm_class_class
= scm_i_make_vtable_vtable (cs
);
908 SCM_SET_CLASS_FLAGS (scm_class_class
, (SCM_CLASSF_GOOPS_OR_VALID
909 | SCM_CLASSF_METACLASS
));
911 SCM_SET_SLOT (scm_class_class
, scm_vtable_index_name
, name
);
912 SCM_SET_SLOT (scm_class_class
, scm_si_direct_supers
, SCM_EOL
); /* will be changed */
913 SCM_SET_SLOT (scm_class_class
, scm_si_direct_slots
, slots_of_class
); /* will be changed */
914 SCM_SET_SLOT (scm_class_class
, scm_si_direct_subclasses
, SCM_EOL
);
915 SCM_SET_SLOT (scm_class_class
, scm_si_direct_methods
, SCM_EOL
);
916 SCM_SET_SLOT (scm_class_class
, scm_si_cpl
, SCM_EOL
); /* will be changed */
917 SCM_SET_SLOT (scm_class_class
, scm_si_slots
, slots_of_class
); /* will be changed */
918 SCM_SET_SLOT (scm_class_class
, scm_si_nfields
, scm_from_int (SCM_N_CLASS_SLOTS
));
919 SCM_SET_SLOT (scm_class_class
, scm_si_getters_n_setters
,
920 compute_getters_n_setters (slots_of_class
)); /* will be changed */
921 SCM_SET_SLOT (scm_class_class
, scm_si_redefined
, SCM_BOOL_F
);
923 prep_hashsets (scm_class_class
);
925 scm_module_define (scm_module_goops
, name
, scm_class_class
);
928 name
= scm_from_latin1_symbol ("<top>");
929 scm_class_top
= scm_basic_make_class (scm_class_class
, name
,
932 scm_module_define (scm_module_goops
, name
, scm_class_top
);
935 name
= scm_from_latin1_symbol ("<object>");
936 scm_class_object
= scm_basic_make_class (scm_class_class
, name
,
937 scm_list_1 (scm_class_top
), SCM_EOL
);
939 scm_module_define (scm_module_goops
, name
, scm_class_object
);
941 /* <top> <object> and <class> were partially initialized. Correct them here */
942 SCM_SET_SLOT (scm_class_object
, scm_si_direct_subclasses
, scm_list_1 (scm_class_class
));
944 SCM_SET_SLOT (scm_class_class
, scm_si_direct_supers
, scm_list_1 (scm_class_object
));
945 SCM_SET_SLOT (scm_class_class
, scm_si_cpl
, scm_list_3 (scm_class_class
, scm_class_object
, scm_class_top
));
948 /******************************************************************************/
950 SCM_DEFINE (scm_instance_p
, "instance?", 1, 0, 0,
952 "Return @code{#t} if @var{obj} is an instance.")
953 #define FUNC_NAME s_scm_instance_p
955 return scm_from_bool (SCM_INSTANCEP (obj
));
960 /******************************************************************************
962 * Meta object accessors
964 ******************************************************************************/
965 SCM_DEFINE (scm_class_name
, "class-name", 1, 0, 0,
967 "Return the class name of @var{obj}.")
968 #define FUNC_NAME s_scm_class_name
970 SCM_VALIDATE_CLASS (1, obj
);
971 return scm_slot_ref (obj
, sym_name
);
975 SCM_DEFINE (scm_class_direct_supers
, "class-direct-supers", 1, 0, 0,
977 "Return the direct superclasses of the class @var{obj}.")
978 #define FUNC_NAME s_scm_class_direct_supers
980 SCM_VALIDATE_CLASS (1, obj
);
981 return scm_slot_ref (obj
, sym_direct_supers
);
985 SCM_DEFINE (scm_class_direct_slots
, "class-direct-slots", 1, 0, 0,
987 "Return the direct slots of the class @var{obj}.")
988 #define FUNC_NAME s_scm_class_direct_slots
990 SCM_VALIDATE_CLASS (1, obj
);
991 return scm_slot_ref (obj
, sym_direct_slots
);
995 SCM_DEFINE (scm_class_direct_subclasses
, "class-direct-subclasses", 1, 0, 0,
997 "Return the direct subclasses of the class @var{obj}.")
998 #define FUNC_NAME s_scm_class_direct_subclasses
1000 SCM_VALIDATE_CLASS (1, obj
);
1001 return scm_slot_ref(obj
, sym_direct_subclasses
);
1005 SCM_DEFINE (scm_class_direct_methods
, "class-direct-methods", 1, 0, 0,
1007 "Return the direct methods of the class @var{obj}")
1008 #define FUNC_NAME s_scm_class_direct_methods
1010 SCM_VALIDATE_CLASS (1, obj
);
1011 return scm_slot_ref (obj
, sym_direct_methods
);
1015 SCM_DEFINE (scm_class_precedence_list
, "class-precedence-list", 1, 0, 0,
1017 "Return the class precedence list of the class @var{obj}.")
1018 #define FUNC_NAME s_scm_class_precedence_list
1020 SCM_VALIDATE_CLASS (1, obj
);
1021 return scm_slot_ref (obj
, sym_cpl
);
1025 SCM_DEFINE (scm_class_slots
, "class-slots", 1, 0, 0,
1027 "Return the slot list of the class @var{obj}.")
1028 #define FUNC_NAME s_scm_class_slots
1030 SCM_VALIDATE_CLASS (1, obj
);
1031 return scm_slot_ref (obj
, sym_slots
);
1035 SCM_DEFINE (scm_generic_function_name
, "generic-function-name", 1, 0, 0,
1037 "Return the name of the generic function @var{obj}.")
1038 #define FUNC_NAME s_scm_generic_function_name
1040 SCM_VALIDATE_GENERIC (1, obj
);
1041 return scm_procedure_property (obj
, scm_sym_name
);
1045 SCM_SYMBOL (sym_methods
, "methods");
1046 SCM_SYMBOL (sym_extended_by
, "extended-by");
1047 SCM_SYMBOL (sym_extends
, "extends");
1050 SCM
fold_downward_gf_methods (SCM method_lists
, SCM gf
)
1052 SCM gfs
= scm_slot_ref (gf
, sym_extended_by
);
1053 method_lists
= scm_cons (scm_slot_ref (gf
, sym_methods
), method_lists
);
1054 while (!scm_is_null (gfs
))
1056 method_lists
= fold_downward_gf_methods (method_lists
, SCM_CAR (gfs
));
1057 gfs
= SCM_CDR (gfs
);
1059 return method_lists
;
1063 SCM
fold_upward_gf_methods (SCM method_lists
, SCM gf
)
1065 if (SCM_IS_A_P (gf
, scm_class_extended_generic
))
1067 SCM gfs
= scm_slot_ref (gf
, sym_extends
);
1068 while (!scm_is_null (gfs
))
1070 SCM methods
= scm_slot_ref (SCM_CAR (gfs
), sym_methods
);
1071 method_lists
= fold_upward_gf_methods (scm_cons (methods
,
1074 gfs
= SCM_CDR (gfs
);
1077 return method_lists
;
1080 SCM_DEFINE (scm_generic_function_methods
, "generic-function-methods", 1, 0, 0,
1082 "Return the methods of the generic function @var{obj}.")
1083 #define FUNC_NAME s_scm_generic_function_methods
1086 SCM_VALIDATE_GENERIC (1, obj
);
1087 methods
= fold_upward_gf_methods (SCM_EOL
, obj
);
1088 methods
= fold_downward_gf_methods (methods
, obj
);
1089 return scm_append (methods
);
1093 SCM_DEFINE (scm_method_generic_function
, "method-generic-function", 1, 0, 0,
1095 "Return the generic function for the method @var{obj}.")
1096 #define FUNC_NAME s_scm_method_generic_function
1098 SCM_VALIDATE_METHOD (1, obj
);
1099 return scm_slot_ref (obj
, scm_from_latin1_symbol ("generic-function"));
1103 SCM_DEFINE (scm_method_specializers
, "method-specializers", 1, 0, 0,
1105 "Return specializers of the method @var{obj}.")
1106 #define FUNC_NAME s_scm_method_specializers
1108 SCM_VALIDATE_METHOD (1, obj
);
1109 return scm_slot_ref (obj
, scm_from_latin1_symbol ("specializers"));
1113 SCM_DEFINE (scm_method_procedure
, "method-procedure", 1, 0, 0,
1115 "Return the procedure of the method @var{obj}.")
1116 #define FUNC_NAME s_scm_method_procedure
1118 SCM_VALIDATE_METHOD (1, obj
);
1119 return scm_slot_ref (obj
, sym_procedure
);
1123 /******************************************************************************
1125 * S l o t a c c e s s
1127 ******************************************************************************/
1129 SCM_DEFINE (scm_make_unbound
, "make-unbound", 0, 0, 0,
1131 "Return the unbound value.")
1132 #define FUNC_NAME s_scm_make_unbound
1134 return SCM_GOOPS_UNBOUND
;
1138 SCM_DEFINE (scm_unbound_p
, "unbound?", 1, 0, 0,
1140 "Return @code{#t} if @var{obj} is unbound.")
1141 #define FUNC_NAME s_scm_unbound_p
1143 return SCM_GOOPS_UNBOUNDP (obj
) ? SCM_BOOL_T
: SCM_BOOL_F
;
1147 SCM_DEFINE (scm_assert_bound
, "assert-bound", 2, 0, 0,
1148 (SCM value
, SCM obj
),
1149 "Return @var{value} if it is bound, and invoke the\n"
1150 "@var{slot-unbound} method of @var{obj} if it is not.")
1151 #define FUNC_NAME s_scm_assert_bound
1153 if (SCM_GOOPS_UNBOUNDP (value
))
1154 return scm_call_1 (SCM_VARIABLE_REF (var_slot_unbound
), obj
);
1159 SCM_DEFINE (scm_at_assert_bound_ref
, "@assert-bound-ref", 2, 0, 0,
1160 (SCM obj
, SCM index
),
1161 "Like @code{assert-bound}, but use @var{index} for accessing\n"
1162 "the value from @var{obj}.")
1163 #define FUNC_NAME s_scm_at_assert_bound_ref
1165 SCM value
= SCM_SLOT (obj
, scm_to_int (index
));
1166 if (SCM_GOOPS_UNBOUNDP (value
))
1167 return scm_call_1 (SCM_VARIABLE_REF (var_slot_unbound
), obj
);
1176 /* In the future, this function will return the effective slot
1177 * definition associated with SLOT_NAME. Now it just returns some of
1178 * the information which will be stored in the effective slot
1183 slot_definition_using_name (SCM
class, SCM slot_name
)
1185 register SCM slots
= SCM_SLOT (class, scm_si_getters_n_setters
);
1186 for (; !scm_is_null (slots
); slots
= SCM_CDR (slots
))
1187 if (scm_is_eq (SCM_CAAR (slots
), slot_name
))
1188 return SCM_CAR (slots
);
1193 get_slot_value (SCM
class SCM_UNUSED
, SCM obj
, SCM slotdef
)
1194 #define FUNC_NAME "%get-slot-value"
1196 SCM access
= SCM_CDDR (slotdef
);
1198 * - access is an integer (the offset of this slot in the slots vector)
1199 * - otherwise (car access) is the getter function to apply
1201 * Instances have never more than SCM_MOST_POSITIVE_FIXNUM slots, so
1202 * we can just assume fixnums here.
1204 if (SCM_I_INUMP (access
))
1205 /* Don't poke at the slots directly, because scm_struct_ref handles the
1206 access bits for us. */
1207 return scm_struct_ref (obj
, access
);
1209 return scm_call_1 (SCM_CAR (access
), obj
);
1214 get_slot_value_using_name (SCM
class, SCM obj
, SCM slot_name
)
1216 SCM slotdef
= slot_definition_using_name (class, slot_name
);
1217 if (scm_is_true (slotdef
))
1218 return get_slot_value (class, obj
, slotdef
);
1220 return scm_call_3 (SCM_VARIABLE_REF (var_slot_missing
), class, obj
, slot_name
);
1224 set_slot_value (SCM
class SCM_UNUSED
, SCM obj
, SCM slotdef
, SCM value
)
1225 #define FUNC_NAME "%set-slot-value"
1227 SCM access
= SCM_CDDR (slotdef
);
1229 * - access is an integer (the offset of this slot in the slots vector)
1230 * - otherwise (cadr access) is the setter function to apply
1232 * Instances have never more than SCM_MOST_POSITIVE_FIXNUM slots, so
1233 * we can just assume fixnums here.
1235 if (SCM_I_INUMP (access
))
1236 /* obey permissions bits via going through struct-set! */
1237 scm_struct_set_x (obj
, access
, value
);
1239 /* ((cadr l) obj value) */
1240 scm_call_2 (SCM_CADR (access
), obj
, value
);
1241 return SCM_UNSPECIFIED
;
1246 set_slot_value_using_name (SCM
class, SCM obj
, SCM slot_name
, SCM value
)
1248 SCM slotdef
= slot_definition_using_name (class, slot_name
);
1249 if (scm_is_true (slotdef
))
1250 return set_slot_value (class, obj
, slotdef
, value
);
1252 return scm_call_4 (SCM_VARIABLE_REF (var_slot_missing
), class, obj
, slot_name
, value
);
1256 test_slot_existence (SCM
class SCM_UNUSED
, SCM obj
, SCM slot_name
)
1260 for (l
= SCM_ACCESSORS_OF (obj
); !scm_is_null (l
); l
= SCM_CDR (l
))
1261 if (scm_is_eq (SCM_CAAR (l
), slot_name
))
1267 /* ======================================== */
1269 SCM_DEFINE (scm_slot_ref_using_class
, "slot-ref-using-class", 3, 0, 0,
1270 (SCM
class, SCM obj
, SCM slot_name
),
1272 #define FUNC_NAME s_scm_slot_ref_using_class
1276 SCM_VALIDATE_CLASS (1, class);
1277 SCM_VALIDATE_INSTANCE (2, obj
);
1278 SCM_VALIDATE_SYMBOL (3, slot_name
);
1280 res
= get_slot_value_using_name (class, obj
, slot_name
);
1281 if (SCM_GOOPS_UNBOUNDP (res
))
1282 return scm_call_3 (SCM_VARIABLE_REF (var_slot_unbound
), class, obj
, slot_name
);
1288 SCM_DEFINE (scm_slot_set_using_class_x
, "slot-set-using-class!", 4, 0, 0,
1289 (SCM
class, SCM obj
, SCM slot_name
, SCM value
),
1291 #define FUNC_NAME s_scm_slot_set_using_class_x
1293 SCM_VALIDATE_CLASS (1, class);
1294 SCM_VALIDATE_INSTANCE (2, obj
);
1295 SCM_VALIDATE_SYMBOL (3, slot_name
);
1297 return set_slot_value_using_name (class, obj
, slot_name
, value
);
1302 SCM_DEFINE (scm_slot_bound_using_class_p
, "slot-bound-using-class?", 3, 0, 0,
1303 (SCM
class, SCM obj
, SCM slot_name
),
1305 #define FUNC_NAME s_scm_slot_bound_using_class_p
1307 SCM_VALIDATE_CLASS (1, class);
1308 SCM_VALIDATE_INSTANCE (2, obj
);
1309 SCM_VALIDATE_SYMBOL (3, slot_name
);
1311 return (SCM_GOOPS_UNBOUNDP (get_slot_value_using_name (class, obj
, slot_name
))
1317 SCM_DEFINE (scm_slot_exists_using_class_p
, "slot-exists-using-class?", 3, 0, 0,
1318 (SCM
class, SCM obj
, SCM slot_name
),
1320 #define FUNC_NAME s_scm_slot_exists_using_class_p
1322 SCM_VALIDATE_CLASS (1, class);
1323 SCM_VALIDATE_INSTANCE (2, obj
);
1324 SCM_VALIDATE_SYMBOL (3, slot_name
);
1325 return test_slot_existence (class, obj
, slot_name
);
1330 /* ======================================== */
1332 SCM_DEFINE (scm_slot_ref
, "slot-ref", 2, 0, 0,
1333 (SCM obj
, SCM slot_name
),
1334 "Return the value from @var{obj}'s slot with the name\n"
1336 #define FUNC_NAME s_scm_slot_ref
1340 SCM_VALIDATE_INSTANCE (1, obj
);
1341 TEST_CHANGE_CLASS (obj
, class);
1343 res
= get_slot_value_using_name (class, obj
, slot_name
);
1344 if (SCM_GOOPS_UNBOUNDP (res
))
1345 return scm_call_3 (SCM_VARIABLE_REF (var_slot_unbound
), class, obj
, slot_name
);
1350 SCM_DEFINE (scm_slot_set_x
, "slot-set!", 3, 0, 0,
1351 (SCM obj
, SCM slot_name
, SCM value
),
1352 "Set the slot named @var{slot_name} of @var{obj} to @var{value}.")
1353 #define FUNC_NAME s_scm_slot_set_x
1357 SCM_VALIDATE_INSTANCE (1, obj
);
1358 TEST_CHANGE_CLASS(obj
, class);
1360 return set_slot_value_using_name (class, obj
, slot_name
, value
);
1364 const char *scm_s_slot_set_x
= s_scm_slot_set_x
;
1366 SCM_DEFINE (scm_slot_bound_p
, "slot-bound?", 2, 0, 0,
1367 (SCM obj
, SCM slot_name
),
1368 "Return @code{#t} if the slot named @var{slot_name} of @var{obj}\n"
1370 #define FUNC_NAME s_scm_slot_bound_p
1374 SCM_VALIDATE_INSTANCE (1, obj
);
1375 TEST_CHANGE_CLASS(obj
, class);
1377 return (SCM_GOOPS_UNBOUNDP (get_slot_value_using_name (class,
1385 SCM_DEFINE (scm_slot_exists_p
, "slot-exists?", 2, 0, 0,
1386 (SCM obj
, SCM slot_name
),
1387 "Return @code{#t} if @var{obj} has a slot named @var{slot_name}.")
1388 #define FUNC_NAME s_scm_slot_exists_p
1392 SCM_VALIDATE_INSTANCE (1, obj
);
1393 SCM_VALIDATE_SYMBOL (2, slot_name
);
1394 TEST_CHANGE_CLASS (obj
, class);
1396 return test_slot_existence (class, obj
, slot_name
);
1401 /******************************************************************************
1403 * %allocate-instance (the low level instance allocation primitive)
1405 ******************************************************************************/
1407 static void clear_method_cache (SCM
);
1409 SCM_DEFINE (scm_sys_allocate_instance
, "%allocate-instance", 2, 0, 0,
1410 (SCM
class, SCM initargs
),
1411 "Create a new instance of class @var{class} and initialize it\n"
1412 "from the arguments @var{initargs}.")
1413 #define FUNC_NAME s_scm_sys_allocate_instance
1416 scm_t_signed_bits n
, i
;
1419 SCM_VALIDATE_CLASS (1, class);
1421 /* FIXME: duplicates some of scm_make_struct. */
1423 n
= SCM_I_INUM (SCM_SLOT (class, scm_si_nfields
));
1424 obj
= scm_i_alloc_struct (SCM_STRUCT_DATA (class), n
);
1426 layout
= SCM_VTABLE_LAYOUT (class);
1428 /* Set all SCM-holding slots to unbound */
1429 for (i
= 0; i
< n
; i
++)
1431 scm_t_wchar c
= scm_i_symbol_ref (layout
, i
*2);
1433 SCM_STRUCT_DATA (obj
)[i
] = SCM_UNPACK (SCM_GOOPS_UNBOUND
);
1435 SCM_STRUCT_DATA (obj
)[i
] = SCM_UNPACK (obj
);
1437 SCM_STRUCT_DATA (obj
)[i
] = 0;
1440 if (SCM_CLASS_FLAGS (class) & SCM_CLASSF_PURE_GENERIC
)
1441 clear_method_cache (obj
);
1447 SCM_DEFINE (scm_sys_set_object_setter_x
, "%set-object-setter!", 2, 0, 0,
1448 (SCM obj
, SCM setter
),
1450 #define FUNC_NAME s_scm_sys_set_object_setter_x
1452 SCM_ASSERT (SCM_STRUCTP (obj
)
1453 && (SCM_OBJ_CLASS_FLAGS (obj
) & SCM_CLASSF_PURE_GENERIC
),
1457 SCM_SET_GENERIC_SETTER (obj
, setter
);
1458 return SCM_UNSPECIFIED
;
1462 /******************************************************************************
1464 * %modify-instance (used by change-class to modify in place)
1466 ******************************************************************************/
1468 SCM_DEFINE (scm_sys_modify_instance
, "%modify-instance", 2, 0, 0,
1471 #define FUNC_NAME s_scm_sys_modify_instance
1473 SCM_VALIDATE_INSTANCE (1, old
);
1474 SCM_VALIDATE_INSTANCE (2, new);
1476 /* Exchange the data contained in old and new. We exchange rather than
1477 * scratch the old value with new to be correct with GC.
1478 * See "Class redefinition protocol above".
1480 SCM_CRITICAL_SECTION_START
;
1482 scm_t_bits word0
, word1
;
1483 word0
= SCM_CELL_WORD_0 (old
);
1484 word1
= SCM_CELL_WORD_1 (old
);
1485 SCM_SET_CELL_WORD_0 (old
, SCM_CELL_WORD_0 (new));
1486 SCM_SET_CELL_WORD_1 (old
, SCM_CELL_WORD_1 (new));
1487 SCM_SET_CELL_WORD_0 (new, word0
);
1488 SCM_SET_CELL_WORD_1 (new, word1
);
1490 SCM_CRITICAL_SECTION_END
;
1491 return SCM_UNSPECIFIED
;
1495 SCM_DEFINE (scm_sys_modify_class
, "%modify-class", 2, 0, 0,
1498 #define FUNC_NAME s_scm_sys_modify_class
1500 SCM_VALIDATE_CLASS (1, old
);
1501 SCM_VALIDATE_CLASS (2, new);
1503 SCM_CRITICAL_SECTION_START
;
1505 scm_t_bits word0
, word1
;
1506 word0
= SCM_CELL_WORD_0 (old
);
1507 word1
= SCM_CELL_WORD_1 (old
);
1508 SCM_SET_CELL_WORD_0 (old
, SCM_CELL_WORD_0 (new));
1509 SCM_SET_CELL_WORD_1 (old
, SCM_CELL_WORD_1 (new));
1510 SCM_STRUCT_DATA (old
)[scm_vtable_index_self
] = SCM_UNPACK (old
);
1511 SCM_SET_CELL_WORD_0 (new, word0
);
1512 SCM_SET_CELL_WORD_1 (new, word1
);
1513 SCM_STRUCT_DATA (new)[scm_vtable_index_self
] = SCM_UNPACK (new);
1515 SCM_CRITICAL_SECTION_END
;
1516 return SCM_UNSPECIFIED
;
1520 SCM_DEFINE (scm_sys_invalidate_class
, "%invalidate-class", 1, 0, 0,
1523 #define FUNC_NAME s_scm_sys_invalidate_class
1525 SCM_VALIDATE_CLASS (1, class);
1526 SCM_CLEAR_CLASS_FLAGS (class, SCM_CLASSF_GOOPS_VALID
);
1527 return SCM_UNSPECIFIED
;
1531 /* When instances change class, they finally get a new body, but
1532 * before that, they go through purgatory in hell. Odd as it may
1533 * seem, this data structure saves us from eternal suffering in
1534 * infinite recursions.
1537 static scm_t_bits
**hell
;
1538 static long n_hell
= 1; /* one place for the evil one himself */
1539 static long hell_size
= 4;
1540 static SCM hell_mutex
;
1546 for (i
= 1; i
< n_hell
; ++i
)
1547 if (SCM_STRUCT_DATA (o
) == hell
[i
])
1553 go_to_hell (void *o
)
1556 scm_lock_mutex (hell_mutex
);
1557 if (n_hell
>= hell_size
)
1560 hell
= scm_realloc (hell
, hell_size
* sizeof(*hell
));
1562 hell
[n_hell
++] = SCM_STRUCT_DATA (obj
);
1563 scm_unlock_mutex (hell_mutex
);
1567 go_to_heaven (void *o
)
1570 scm_lock_mutex (hell_mutex
);
1571 hell
[burnin (obj
)] = hell
[--n_hell
];
1572 scm_unlock_mutex (hell_mutex
);
1576 SCM_SYMBOL (scm_sym_change_class
, "change-class");
1579 purgatory (SCM obj
, SCM new_class
)
1581 return scm_call_2 (SCM_VARIABLE_REF (var_change_class
), obj
, new_class
);
1584 /* This function calls the generic function change-class for all
1585 * instances which aren't currently undergoing class change.
1589 scm_change_object_class (SCM obj
, SCM old_class SCM_UNUSED
, SCM new_class
)
1593 scm_dynwind_begin (SCM_F_DYNWIND_REWINDABLE
);
1594 scm_dynwind_rewind_handler (go_to_hell
, &obj
, SCM_F_WIND_EXPLICITLY
);
1595 scm_dynwind_unwind_handler (go_to_heaven
, &obj
, SCM_F_WIND_EXPLICITLY
);
1596 purgatory (obj
, new_class
);
1601 /******************************************************************************
1607 * GGG E N E R I C F U N C T I O N S
1609 * This implementation provides
1610 * - generic functions (with class specializers)
1613 * - a hard-coded MOP for standard gf, which can be overloaded for non-std gf
1615 ******************************************************************************/
1617 SCM_KEYWORD (k_name
, "name");
1619 SCM_GLOBAL_SYMBOL (scm_sym_args
, "args");
1621 SCM_SYMBOL (sym_delayed_compile
, "delayed-compile");
1623 static SCM delayed_compile_var
;
1626 init_delayed_compile_var (void)
1629 = scm_c_private_lookup ("oop goops dispatch", "delayed-compile");
1633 make_dispatch_procedure (SCM gf
)
1635 static scm_i_pthread_once_t once
= SCM_I_PTHREAD_ONCE_INIT
;
1636 scm_i_pthread_once (&once
, init_delayed_compile_var
);
1638 return scm_call_1 (scm_variable_ref (delayed_compile_var
), gf
);
1642 clear_method_cache (SCM gf
)
1644 SCM_SET_GENERIC_DISPATCH_PROCEDURE (gf
, make_dispatch_procedure (gf
));
1645 SCM_CLEAR_GENERIC_EFFECTIVE_METHODS (gf
);
1648 SCM_DEFINE (scm_sys_invalidate_method_cache_x
, "%invalidate-method-cache!", 1, 0, 0,
1651 #define FUNC_NAME s_scm_sys_invalidate_method_cache_x
1653 SCM_ASSERT (SCM_PUREGENERICP (gf
), gf
, SCM_ARG1
, FUNC_NAME
);
1654 clear_method_cache (gf
);
1655 return SCM_UNSPECIFIED
;
1659 SCM_DEFINE (scm_generic_capability_p
, "generic-capability?", 1, 0, 0,
1662 #define FUNC_NAME s_scm_generic_capability_p
1664 SCM_ASSERT (scm_is_true (scm_procedure_p (proc
)),
1665 proc
, SCM_ARG1
, FUNC_NAME
);
1666 return (SCM_PRIMITIVE_GENERIC_P (proc
) ? SCM_BOOL_T
: SCM_BOOL_F
);
1670 SCM_DEFINE (scm_enable_primitive_generic_x
, "enable-primitive-generic!", 0, 0, 1,
1673 #define FUNC_NAME s_scm_enable_primitive_generic_x
1675 SCM_VALIDATE_REST_ARGUMENT (subrs
);
1676 while (!scm_is_null (subrs
))
1678 SCM subr
= SCM_CAR (subrs
);
1679 SCM_ASSERT (SCM_PRIMITIVE_GENERIC_P (subr
), subr
, SCM_ARGn
, FUNC_NAME
);
1680 SCM_SET_SUBR_GENERIC (subr
,
1681 scm_make (scm_list_3 (scm_class_generic
,
1683 SCM_SUBR_NAME (subr
))));
1684 subrs
= SCM_CDR (subrs
);
1686 return SCM_UNSPECIFIED
;
1690 SCM_DEFINE (scm_set_primitive_generic_x
, "set-primitive-generic!", 2, 0, 0,
1691 (SCM subr
, SCM generic
),
1693 #define FUNC_NAME s_scm_set_primitive_generic_x
1695 SCM_ASSERT (SCM_PRIMITIVE_GENERIC_P (subr
), subr
, SCM_ARG1
, FUNC_NAME
);
1696 SCM_ASSERT (SCM_PUREGENERICP (generic
), generic
, SCM_ARG2
, FUNC_NAME
);
1697 SCM_SET_SUBR_GENERIC (subr
, generic
);
1698 return SCM_UNSPECIFIED
;
1702 SCM_DEFINE (scm_primitive_generic_generic
, "primitive-generic-generic", 1, 0, 0,
1705 #define FUNC_NAME s_scm_primitive_generic_generic
1707 if (SCM_PRIMITIVE_GENERIC_P (subr
))
1709 if (!SCM_UNPACK (*SCM_SUBR_GENERIC (subr
)))
1710 scm_enable_primitive_generic_x (scm_list_1 (subr
));
1711 return *SCM_SUBR_GENERIC (subr
);
1713 SCM_WRONG_TYPE_ARG (SCM_ARG1
, subr
);
1717 typedef struct t_extension
{
1718 struct t_extension
*next
;
1724 /* Hint for `scm_gc_malloc ()' et al. when allocating `t_extension'
1726 static const char extension_gc_hint
[] = "GOOPS extension";
1728 static t_extension
*extensions
= 0;
1731 scm_c_extend_primitive_generic (SCM extended
, SCM extension
)
1736 if (!SCM_UNPACK (*SCM_SUBR_GENERIC (extended
)))
1737 scm_enable_primitive_generic_x (scm_list_1 (extended
));
1738 gf
= *SCM_SUBR_GENERIC (extended
);
1739 gext
= scm_call_2 (SCM_VARIABLE_REF (scm_var_make_extended_generic
),
1741 SCM_SUBR_NAME (extension
));
1742 SCM_SET_SUBR_GENERIC (extension
, gext
);
1746 t_extension
*e
= scm_gc_malloc (sizeof (t_extension
),
1748 t_extension
**loc
= &extensions
;
1749 /* Make sure that extensions are placed before their own
1750 * extensions in the extensions list. O(N^2) algorithm, but
1751 * extensions of primitive generics are rare.
1753 while (*loc
&& !scm_is_eq (extension
, (*loc
)->extended
))
1754 loc
= &(*loc
)->next
;
1756 e
->extended
= extended
;
1757 e
->extension
= extension
;
1763 setup_extended_primitive_generics ()
1767 t_extension
*e
= extensions
;
1768 scm_c_extend_primitive_generic (e
->extended
, e
->extension
);
1769 extensions
= e
->next
;
1773 /* Dirk:FIXME:: In all of these scm_wta_dispatch_* routines it is
1774 * assumed that 'gf' is zero if uninitialized. It would be cleaner if
1775 * some valid SCM value like SCM_BOOL_F or SCM_UNDEFINED were chosen.
1779 scm_wta_dispatch_0 (SCM gf
, const char *subr
)
1781 if (!SCM_UNPACK (gf
))
1782 scm_error_num_args_subr (subr
);
1784 return scm_call_0 (gf
);
1788 scm_wta_dispatch_1 (SCM gf
, SCM a1
, int pos
, const char *subr
)
1790 if (!SCM_UNPACK (gf
))
1791 scm_wrong_type_arg (subr
, pos
, a1
);
1793 return scm_call_1 (gf
, a1
);
1797 scm_wta_dispatch_2 (SCM gf
, SCM a1
, SCM a2
, int pos
, const char *subr
)
1799 if (!SCM_UNPACK (gf
))
1800 scm_wrong_type_arg (subr
, pos
, (pos
== SCM_ARG1
) ? a1
: a2
);
1802 return scm_call_2 (gf
, a1
, a2
);
1806 scm_wta_dispatch_n (SCM gf
, SCM args
, int pos
, const char *subr
)
1808 if (!SCM_UNPACK (gf
))
1809 scm_wrong_type_arg (subr
, pos
, scm_list_ref (args
, scm_from_int (pos
)));
1811 return scm_apply_0 (gf
, args
);
1814 /******************************************************************************
1816 * Protocol for calling a generic fumction
1817 * This protocol is roughly equivalent to (parameter are a little bit different
1818 * for efficiency reasons):
1820 * + apply-generic (gf args)
1821 * + compute-applicable-methods (gf args ...)
1822 * + sort-applicable-methods (methods args)
1823 * + apply-methods (gf methods args)
1825 * apply-methods calls make-next-method to build the "continuation" of a a
1826 * method. Applying a next-method will call apply-next-method which in
1827 * turn will call apply again to call effectively the following method.
1829 ******************************************************************************/
1831 /******************************************************************************
1833 * A simple make (which will be redefined later in Scheme)
1834 * This version handles only creation of gf, methods and classes (no instances)
1836 * Since this code will disappear when Goops will be fully booted,
1837 * no precaution is taken to be efficient.
1839 ******************************************************************************/
1841 SCM_KEYWORD (k_setter
, "setter");
1842 SCM_KEYWORD (k_specializers
, "specializers");
1843 SCM_KEYWORD (k_procedure
, "procedure");
1844 SCM_KEYWORD (k_formals
, "formals");
1845 SCM_KEYWORD (k_body
, "body");
1846 SCM_KEYWORD (k_make_procedure
, "make-procedure");
1847 SCM_KEYWORD (k_dsupers
, "dsupers");
1848 SCM_KEYWORD (k_slots
, "slots");
1849 SCM_KEYWORD (k_gf
, "generic-function");
1851 SCM_DEFINE (scm_make
, "make", 0, 0, 1,
1853 "Make a new object. @var{args} must contain the class and\n"
1854 "all necessary initialization information.")
1855 #define FUNC_NAME s_scm_make
1858 long len
= scm_ilength (args
);
1860 if (len
<= 0 || (len
& 1) == 0)
1861 SCM_WRONG_NUM_ARGS ();
1863 class = SCM_CAR(args
);
1864 args
= SCM_CDR(args
);
1866 if (scm_is_eq (class, scm_class_generic
)
1867 || scm_is_eq (class, scm_class_accessor
))
1869 z
= scm_make_struct (class, SCM_INUM0
,
1870 scm_list_4 (SCM_BOOL_F
,
1874 scm_set_procedure_property_x (z
, scm_sym_name
,
1875 scm_get_keyword (k_name
,
1878 clear_method_cache (z
);
1879 if (scm_is_eq (class, scm_class_accessor
))
1881 SCM setter
= scm_get_keyword (k_setter
, args
, SCM_BOOL_F
);
1882 if (scm_is_true (setter
))
1883 scm_sys_set_object_setter_x (z
, setter
);
1888 z
= scm_sys_allocate_instance (class, args
);
1890 if (scm_is_eq (class, scm_class_method
)
1891 || scm_is_eq (class, scm_class_accessor_method
))
1893 SCM_SET_SLOT (z
, scm_si_generic_function
,
1894 scm_i_get_keyword (k_gf
,
1899 SCM_SET_SLOT (z
, scm_si_specializers
,
1900 scm_i_get_keyword (k_specializers
,
1905 SCM_SET_SLOT (z
, scm_si_procedure
,
1906 scm_i_get_keyword (k_procedure
,
1911 SCM_SET_SLOT (z
, scm_si_formals
,
1912 scm_i_get_keyword (k_formals
,
1917 SCM_SET_SLOT (z
, scm_si_body
,
1918 scm_i_get_keyword (k_body
,
1923 SCM_SET_SLOT (z
, scm_si_make_procedure
,
1924 scm_i_get_keyword (k_make_procedure
,
1932 /* In all the others case, make a new class .... No instance here */
1933 SCM_SET_SLOT (z
, scm_vtable_index_name
,
1934 scm_i_get_keyword (k_name
,
1937 scm_from_latin1_symbol ("???"),
1939 SCM_SET_SLOT (z
, scm_si_direct_supers
,
1940 scm_i_get_keyword (k_dsupers
,
1945 SCM_SET_SLOT (z
, scm_si_direct_slots
,
1946 scm_i_get_keyword (k_slots
,
1958 /******************************************************************************
1962 ******************************************************************************/
1965 make_stdcls (SCM
*var
, char *name
, SCM meta
, SCM super
, SCM slots
)
1967 SCM tmp
= scm_from_utf8_symbol (name
);
1969 *var
= scm_basic_make_class (meta
, tmp
,
1970 scm_is_pair (super
) ? super
: scm_list_1 (super
),
1972 scm_module_define (scm_module_goops
, tmp
, *var
);
1976 SCM_KEYWORD (k_slot_definition
, "slot-definition");
1979 create_standard_classes (void)
1982 SCM method_slots
= scm_list_n (scm_from_latin1_symbol ("generic-function"),
1983 scm_from_latin1_symbol ("specializers"),
1985 scm_from_latin1_symbol ("formals"),
1986 scm_from_latin1_symbol ("body"),
1987 scm_from_latin1_symbol ("make-procedure"),
1989 SCM amethod_slots
= scm_list_1 (scm_list_3 (scm_from_latin1_symbol ("slot-definition"),
1991 k_slot_definition
));
1992 SCM gf_slots
= scm_list_4 (scm_from_latin1_symbol ("methods"),
1993 scm_list_3 (scm_from_latin1_symbol ("n-specialized"),
1996 scm_list_3 (scm_from_latin1_symbol ("extended-by"),
1999 scm_from_latin1_symbol ("effective-methods"));
2000 SCM setter_slots
= scm_list_1 (sym_setter
);
2001 SCM egf_slots
= scm_list_1 (scm_list_3 (scm_from_latin1_symbol ("extends"),
2004 /* Foreign class slot classes */
2005 make_stdcls (&scm_class_foreign_slot
, "<foreign-slot>",
2006 scm_class_class
, scm_class_top
, SCM_EOL
);
2007 make_stdcls (&scm_class_protected
, "<protected-slot>",
2008 scm_class_class
, scm_class_foreign_slot
, SCM_EOL
);
2009 make_stdcls (&scm_class_hidden
, "<hidden-slot>",
2010 scm_class_class
, scm_class_foreign_slot
, SCM_EOL
);
2011 make_stdcls (&scm_class_opaque
, "<opaque-slot>",
2012 scm_class_class
, scm_class_foreign_slot
, SCM_EOL
);
2013 make_stdcls (&scm_class_read_only
, "<read-only-slot>",
2014 scm_class_class
, scm_class_foreign_slot
, SCM_EOL
);
2015 make_stdcls (&scm_class_self
, "<self-slot>",
2016 scm_class_class
, scm_class_read_only
, SCM_EOL
);
2017 make_stdcls (&scm_class_protected_opaque
, "<protected-opaque-slot>",
2019 scm_list_2 (scm_class_protected
, scm_class_opaque
),
2021 make_stdcls (&scm_class_protected_hidden
, "<protected-hidden-slot>",
2023 scm_list_2 (scm_class_protected
, scm_class_hidden
),
2025 make_stdcls (&scm_class_protected_read_only
, "<protected-read-only-slot>",
2027 scm_list_2 (scm_class_protected
, scm_class_read_only
),
2029 make_stdcls (&scm_class_scm
, "<scm-slot>",
2030 scm_class_class
, scm_class_protected
, SCM_EOL
);
2031 make_stdcls (&scm_class_int
, "<int-slot>",
2032 scm_class_class
, scm_class_foreign_slot
, SCM_EOL
);
2033 make_stdcls (&scm_class_float
, "<float-slot>",
2034 scm_class_class
, scm_class_foreign_slot
, SCM_EOL
);
2035 make_stdcls (&scm_class_double
, "<double-slot>",
2036 scm_class_class
, scm_class_foreign_slot
, SCM_EOL
);
2038 specialized_slots_initialized
= 1;
2040 /* Finish initialization of class <class> */
2042 slots
= build_class_class_slots (FINAL_SLOTS
);
2043 SCM_SET_SLOT (scm_class_class
, scm_si_direct_slots
, slots
);
2044 SCM_SET_SLOT (scm_class_class
, scm_si_slots
, slots
);
2045 SCM_SET_SLOT (scm_class_class
, scm_si_getters_n_setters
,
2046 compute_getters_n_setters (slots
));
2048 /* scm_class_generic functions classes */
2049 make_stdcls (&scm_class_procedure_class
, "<procedure-class>",
2050 scm_class_class
, scm_class_class
, SCM_EOL
);
2051 make_stdcls (&scm_class_applicable_struct_class
, "<applicable-struct-class>",
2052 scm_class_class
, scm_class_procedure_class
, SCM_EOL
);
2053 SCM_SET_VTABLE_FLAGS (scm_class_applicable_struct_class
, SCM_VTABLE_FLAG_APPLICABLE_VTABLE
);
2054 make_stdcls (&scm_class_method
, "<method>",
2055 scm_class_class
, scm_class_object
, method_slots
);
2056 make_stdcls (&scm_class_accessor_method
, "<accessor-method>",
2057 scm_class_class
, scm_class_method
, amethod_slots
);
2058 make_stdcls (&scm_class_applicable
, "<applicable>",
2059 scm_class_class
, scm_class_top
, SCM_EOL
);
2060 make_stdcls (&scm_class_applicable_struct
, "<applicable-struct>",
2061 scm_class_applicable_struct_class
,
2062 scm_list_2 (scm_class_object
, scm_class_applicable
),
2063 scm_list_1 (sym_procedure
));
2064 make_stdcls (&scm_class_generic
, "<generic>",
2065 scm_class_applicable_struct_class
, scm_class_applicable_struct
, gf_slots
);
2066 SCM_SET_CLASS_FLAGS (scm_class_generic
, SCM_CLASSF_PURE_GENERIC
);
2067 make_stdcls (&scm_class_extended_generic
, "<extended-generic>",
2068 scm_class_applicable_struct_class
, scm_class_generic
, egf_slots
);
2069 SCM_SET_CLASS_FLAGS (scm_class_extended_generic
, SCM_CLASSF_PURE_GENERIC
);
2070 make_stdcls (&scm_class_generic_with_setter
, "<generic-with-setter>",
2071 scm_class_applicable_struct_class
, scm_class_generic
, setter_slots
);
2072 SCM_SET_CLASS_FLAGS (scm_class_generic_with_setter
, SCM_CLASSF_PURE_GENERIC
);
2073 make_stdcls (&scm_class_accessor
, "<accessor>",
2074 scm_class_applicable_struct_class
, scm_class_generic_with_setter
, SCM_EOL
);
2075 SCM_SET_CLASS_FLAGS (scm_class_accessor
, SCM_CLASSF_PURE_GENERIC
);
2076 make_stdcls (&scm_class_extended_generic_with_setter
,
2077 "<extended-generic-with-setter>",
2078 scm_class_applicable_struct_class
,
2079 scm_list_2 (scm_class_extended_generic
,
2080 scm_class_generic_with_setter
),
2082 SCM_SET_CLASS_FLAGS (scm_class_extended_generic_with_setter
,
2083 SCM_CLASSF_PURE_GENERIC
);
2084 make_stdcls (&scm_class_extended_accessor
, "<extended-accessor>",
2085 scm_class_applicable_struct_class
,
2086 scm_list_2 (scm_class_accessor
,
2087 scm_class_extended_generic_with_setter
),
2089 SCM_SET_CLASS_FLAGS (scm_class_extended_accessor
, SCM_CLASSF_PURE_GENERIC
);
2091 /* Primitive types classes */
2092 make_stdcls (&scm_class_boolean
, "<boolean>",
2093 scm_class_class
, scm_class_top
, SCM_EOL
);
2094 make_stdcls (&scm_class_char
, "<char>",
2095 scm_class_class
, scm_class_top
, SCM_EOL
);
2096 make_stdcls (&scm_class_list
, "<list>",
2097 scm_class_class
, scm_class_top
, SCM_EOL
);
2098 make_stdcls (&scm_class_pair
, "<pair>",
2099 scm_class_class
, scm_class_list
, SCM_EOL
);
2100 make_stdcls (&scm_class_null
, "<null>",
2101 scm_class_class
, scm_class_list
, SCM_EOL
);
2102 make_stdcls (&scm_class_string
, "<string>",
2103 scm_class_class
, scm_class_top
, SCM_EOL
);
2104 make_stdcls (&scm_class_symbol
, "<symbol>",
2105 scm_class_class
, scm_class_top
, SCM_EOL
);
2106 make_stdcls (&scm_class_vector
, "<vector>",
2107 scm_class_class
, scm_class_top
, SCM_EOL
);
2108 make_stdcls (&class_foreign
, "<foreign>",
2109 scm_class_class
, scm_class_top
, SCM_EOL
);
2110 make_stdcls (&class_hashtable
, "<hashtable>",
2111 scm_class_class
, scm_class_top
, SCM_EOL
);
2112 make_stdcls (&class_fluid
, "<fluid>",
2113 scm_class_class
, scm_class_top
, SCM_EOL
);
2114 make_stdcls (&class_dynamic_state
, "<dynamic-state>",
2115 scm_class_class
, scm_class_top
, SCM_EOL
);
2116 make_stdcls (&class_frame
, "<frame>",
2117 scm_class_class
, scm_class_top
, SCM_EOL
);
2118 make_stdcls (&class_vm_cont
, "<vm-continuation>",
2119 scm_class_class
, scm_class_top
, SCM_EOL
);
2120 make_stdcls (&class_bytevector
, "<bytevector>",
2121 scm_class_class
, scm_class_top
, SCM_EOL
);
2122 make_stdcls (&class_uvec
, "<uvec>",
2123 scm_class_class
, class_bytevector
, SCM_EOL
);
2124 make_stdcls (&class_array
, "<array>",
2125 scm_class_class
, scm_class_top
, SCM_EOL
);
2126 make_stdcls (&class_bitvector
, "<bitvector>",
2127 scm_class_class
, scm_class_top
, SCM_EOL
);
2128 make_stdcls (&scm_class_number
, "<number>",
2129 scm_class_class
, scm_class_top
, SCM_EOL
);
2130 make_stdcls (&scm_class_complex
, "<complex>",
2131 scm_class_class
, scm_class_number
, SCM_EOL
);
2132 make_stdcls (&scm_class_real
, "<real>",
2133 scm_class_class
, scm_class_complex
, SCM_EOL
);
2134 make_stdcls (&scm_class_integer
, "<integer>",
2135 scm_class_class
, scm_class_real
, SCM_EOL
);
2136 make_stdcls (&scm_class_fraction
, "<fraction>",
2137 scm_class_class
, scm_class_real
, SCM_EOL
);
2138 make_stdcls (&scm_class_keyword
, "<keyword>",
2139 scm_class_class
, scm_class_top
, SCM_EOL
);
2140 make_stdcls (&scm_class_unknown
, "<unknown>",
2141 scm_class_class
, scm_class_top
, SCM_EOL
);
2142 make_stdcls (&scm_class_procedure
, "<procedure>",
2143 scm_class_procedure_class
, scm_class_applicable
, SCM_EOL
);
2144 make_stdcls (&scm_class_primitive_generic
, "<primitive-generic>",
2145 scm_class_procedure_class
, scm_class_procedure
, SCM_EOL
);
2146 make_stdcls (&scm_class_port
, "<port>",
2147 scm_class_class
, scm_class_top
, SCM_EOL
);
2148 make_stdcls (&scm_class_input_port
, "<input-port>",
2149 scm_class_class
, scm_class_port
, SCM_EOL
);
2150 make_stdcls (&scm_class_output_port
, "<output-port>",
2151 scm_class_class
, scm_class_port
, SCM_EOL
);
2152 make_stdcls (&scm_class_input_output_port
, "<input-output-port>",
2154 scm_list_2 (scm_class_input_port
, scm_class_output_port
),
2158 /**********************************************************************
2162 **********************************************************************/
2165 make_class_from_template (char const *template, char const *type_name
, SCM supers
, int applicablep
)
2171 sprintf (buffer
, template, type_name
);
2172 name
= scm_from_utf8_symbol (buffer
);
2175 name
= SCM_GOOPS_UNBOUND
;
2177 return scm_basic_make_class (applicablep
? scm_class_procedure_class
: scm_class_class
,
2178 name
, supers
, SCM_EOL
);
2182 make_class_from_symbol (SCM type_name_sym
, SCM supers
, int applicablep
)
2186 if (scm_is_true (type_name_sym
))
2188 name
= scm_string_append (scm_list_3 (scm_from_locale_string ("<"),
2189 scm_symbol_to_string (type_name_sym
),
2190 scm_from_locale_string (">")));
2191 name
= scm_string_to_symbol (name
);
2194 name
= SCM_GOOPS_UNBOUND
;
2196 return scm_basic_make_class (applicablep
? scm_class_procedure_class
: scm_class_class
,
2197 name
, supers
, SCM_EOL
);
2201 scm_make_extended_class (char const *type_name
, int applicablep
)
2203 return make_class_from_template ("<%s>",
2205 scm_list_1 (applicablep
2206 ? scm_class_applicable
2212 scm_make_extended_class_from_symbol (SCM type_name_sym
, int applicablep
)
2214 return make_class_from_symbol (type_name_sym
,
2215 scm_list_1 (applicablep
2216 ? scm_class_applicable
2222 scm_i_inherit_applicable (SCM c
)
2224 if (!SCM_SUBCLASSP (c
, scm_class_applicable
))
2226 SCM dsupers
= SCM_SLOT (c
, scm_si_direct_supers
);
2227 SCM cpl
= SCM_SLOT (c
, scm_si_cpl
);
2228 /* patch scm_class_applicable into direct-supers */
2229 SCM top
= scm_c_memq (scm_class_top
, dsupers
);
2230 if (scm_is_false (top
))
2231 dsupers
= scm_append (scm_list_2 (dsupers
,
2232 scm_list_1 (scm_class_applicable
)));
2235 SCM_SETCAR (top
, scm_class_applicable
);
2236 SCM_SETCDR (top
, scm_cons (scm_class_top
, SCM_CDR (top
)));
2238 SCM_SET_SLOT (c
, scm_si_direct_supers
, dsupers
);
2239 /* patch scm_class_applicable into cpl */
2240 top
= scm_c_memq (scm_class_top
, cpl
);
2241 if (scm_is_false (top
))
2245 SCM_SETCAR (top
, scm_class_applicable
);
2246 SCM_SETCDR (top
, scm_cons (scm_class_top
, SCM_CDR (top
)));
2248 /* add class to direct-subclasses of scm_class_applicable */
2249 SCM_SET_SLOT (scm_class_applicable
,
2250 scm_si_direct_subclasses
,
2251 scm_cons (c
, SCM_SLOT (scm_class_applicable
,
2252 scm_si_direct_subclasses
)));
2257 create_smob_classes (void)
2261 for (i
= 0; i
< SCM_I_MAX_SMOB_TYPE_COUNT
; ++i
)
2262 scm_smob_class
[i
] = SCM_BOOL_F
;
2264 for (i
= 0; i
< scm_numsmob
; ++i
)
2265 if (scm_is_false (scm_smob_class
[i
]))
2266 scm_smob_class
[i
] = scm_make_extended_class (SCM_SMOBNAME (i
),
2267 scm_smobs
[i
].apply
!= 0);
2271 scm_make_port_classes (long ptobnum
, char *type_name
)
2273 SCM c
, class = make_class_from_template ("<%s-port>",
2275 scm_list_1 (scm_class_port
),
2277 scm_port_class
[SCM_IN_PCLASS_INDEX
+ ptobnum
]
2278 = make_class_from_template ("<%s-input-port>",
2280 scm_list_2 (class, scm_class_input_port
),
2282 scm_port_class
[SCM_OUT_PCLASS_INDEX
+ ptobnum
]
2283 = make_class_from_template ("<%s-output-port>",
2285 scm_list_2 (class, scm_class_output_port
),
2287 scm_port_class
[SCM_INOUT_PCLASS_INDEX
+ ptobnum
]
2289 = make_class_from_template ("<%s-input-output-port>",
2291 scm_list_2 (class, scm_class_input_output_port
),
2293 /* Patch cpl (since this tree is too complex for the C level compute-cpl) */
2294 SCM_SET_SLOT (c
, scm_si_cpl
,
2295 scm_cons2 (c
, class, SCM_SLOT (scm_class_input_output_port
, scm_si_cpl
)));
2299 create_port_classes (void)
2303 for (i
= scm_c_num_port_types () - 1; i
>= 0; i
--)
2304 scm_make_port_classes (i
, SCM_PTOBNAME (i
));
2308 make_struct_class (void *closure SCM_UNUSED
,
2309 SCM vtable
, SCM data
, SCM prev SCM_UNUSED
)
2311 if (scm_is_false (data
))
2312 scm_i_define_class_for_vtable (vtable
);
2313 return SCM_UNSPECIFIED
;
2317 create_struct_classes (void)
2319 /* FIXME: take the vtable_class_map while initializing goops? */
2320 scm_internal_hash_fold (make_struct_class
, 0, SCM_BOOL_F
,
2324 /**********************************************************************
2328 **********************************************************************/
2333 if (!goops_loaded_p
)
2334 scm_c_resolve_module ("oop goops");
2338 SCM_SYMBOL (sym_o
, "o");
2339 SCM_SYMBOL (sym_x
, "x");
2341 SCM_KEYWORD (k_accessor
, "accessor");
2342 SCM_KEYWORD (k_getter
, "getter");
2345 scm_ensure_accessor (SCM name
)
2349 var
= scm_module_variable (scm_current_module (), name
);
2350 if (SCM_VARIABLEP (var
) && !SCM_UNBNDP (SCM_VARIABLE_REF (var
)))
2351 gf
= SCM_VARIABLE_REF (var
);
2355 if (!SCM_IS_A_P (gf
, scm_class_accessor
))
2357 gf
= scm_make (scm_list_3 (scm_class_generic
, k_name
, name
));
2358 gf
= scm_make (scm_list_5 (scm_class_accessor
,
2359 k_name
, name
, k_setter
, gf
));
2367 * Debugging utilities
2370 SCM_DEFINE (scm_pure_generic_p
, "pure-generic?", 1, 0, 0,
2372 "Return @code{#t} if @var{obj} is a pure generic.")
2373 #define FUNC_NAME s_scm_pure_generic_p
2375 return scm_from_bool (SCM_PUREGENERICP (obj
));
2379 #endif /* GUILE_DEBUG */
2385 SCM_DEFINE (scm_sys_goops_early_init
, "%goops-early-init", 0, 0, 0,
2388 #define FUNC_NAME s_scm_sys_goops_early_init
2390 create_basic_classes ();
2391 create_standard_classes ();
2392 create_smob_classes ();
2393 create_struct_classes ();
2394 create_port_classes ();
2397 SCM name
= scm_from_latin1_symbol ("no-applicable-method");
2398 scm_no_applicable_method
=
2399 scm_make (scm_list_3 (scm_class_generic
, k_name
, name
));
2400 scm_module_define (scm_module_goops
, name
, scm_no_applicable_method
);
2403 return SCM_UNSPECIFIED
;
2407 SCM_DEFINE (scm_sys_goops_loaded
, "%goops-loaded", 0, 0, 0,
2409 "Announce that GOOPS is loaded and perform initialization\n"
2410 "on the C level which depends on the loaded GOOPS modules.")
2411 #define FUNC_NAME s_scm_sys_goops_loaded
2415 scm_module_variable (scm_module_goops
, sym_slot_unbound
);
2417 scm_module_variable (scm_module_goops
, sym_slot_missing
);
2418 var_no_applicable_method
=
2419 scm_module_variable (scm_module_goops
, sym_no_applicable_method
);
2421 scm_module_variable (scm_module_goops
, sym_change_class
);
2422 setup_extended_primitive_generics ();
2423 return SCM_UNSPECIFIED
;
2427 SCM scm_module_goops
;
2430 scm_init_goops_builtins (void *unused
)
2432 scm_module_goops
= scm_current_module ();
2434 goops_rstate
= scm_c_make_rstate ("GOOPS", 5);
2436 hell
= scm_calloc (hell_size
* sizeof (*hell
));
2437 hell_mutex
= scm_make_mutex ();
2439 #include "libguile/goops.x"
2442 scm_module_variable (scm_module_goops
, sym_compute_cpl
);
2448 scm_c_register_extension ("libguile-" SCM_EFFECTIVE_VERSION
,
2449 "scm_init_goops_builtins", scm_init_goops_builtins
,