1 /* Copyright (C) 1998,1999,2000,2001,2002,2003,2004,2008,2009
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
6 * License as published by the Free Software Foundation; either
7 * version 2.1 of the License, or (at your option) any later version.
9 * This library is distributed in the hope that it will be useful,
10 * but WITHOUT ANY WARRANTY; without even the implied warranty of
11 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
12 * Lesser General Public License for more details.
14 * You should have received a copy of the GNU Lesser General Public
15 * License along with this library; if not, write to the Free Software
16 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
20 /* This software is a derivative work of other copyrighted softwares; the
21 * copyright notices of these softwares are placed in the file COPYRIGHTS
23 * This file is based upon stklos.c from the STk distribution by
24 * 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/hashtab.h"
43 #include "libguile/keywords.h"
44 #include "libguile/macros.h"
45 #include "libguile/modules.h"
46 #include "libguile/objects.h"
47 #include "libguile/ports.h"
48 #include "libguile/procprop.h"
49 #include "libguile/random.h"
50 #include "libguile/root.h"
51 #include "libguile/smob.h"
52 #include "libguile/strings.h"
53 #include "libguile/strports.h"
54 #include "libguile/vectors.h"
55 #include "libguile/weaks.h"
57 #include "libguile/validate.h"
58 #include "libguile/goops.h"
60 #define SPEC_OF(x) SCM_SLOT (x, scm_si_specializers)
62 #define DEFVAR(v, val) \
63 { scm_eval (scm_list_3 (scm_sym_define_public, (v), (val)), \
65 /* Temporary hack until we get the new module system */
66 /*fixme* Should optimize by keeping track of the variable object itself */
67 #define GETVAR(v) (SCM_VARIABLE_REF (scm_call_2 (scm_goops_lookup_closure, \
70 /* Fixme: Should use already interned symbols */
72 #define CALL_GF1(name, a) (scm_call_1 (GETVAR (scm_from_locale_symbol (name)), \
74 #define CALL_GF2(name, a, b) (scm_call_2 (GETVAR (scm_from_locale_symbol (name)), \
76 #define CALL_GF3(name, a, b, c) (scm_call_3 (GETVAR (scm_from_locale_symbol (name)), \
78 #define CALL_GF4(name, a, b, c, d) (scm_call_4 (GETVAR (scm_from_locale_symbol (name)), \
81 /* Class redefinition protocol:
83 A class is represented by a heap header h1 which points to a
84 malloc:ed memory block m1.
86 When a new version of a class is created, a new header h2 and
87 memory block m2 are allocated. The headers h1 and h2 then switch
88 pointers so that h1 refers to m2 and h2 to m1. In this way, names
89 bound to h1 will point to the new class at the same time as h2 will
90 be a handle which the GC will use to free m1.
92 The `redefined' slot of m1 will be set to point to h1. An old
93 instance will have its class pointer (the CAR of the heap header)
94 pointing to m1. The non-immediate `redefined'-slot in m1 indicates
95 the class modification and the new class pointer can be found via
99 /* The following definition is located in libguile/objects.h:
100 #define SCM_OBJ_CLASS_REDEF(x) (SCM_STRUCT_VTABLE_DATA(x)[scm_si_redefined])
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 NXT_MTHD_METHODS(m) (SCM_VELTS (m)[1])
114 #define NXT_MTHD_ARGS(m) (SCM_VELTS (m)[2])
116 #define SCM_GOOPS_UNBOUND SCM_UNBOUND
117 #define SCM_GOOPS_UNBOUNDP(x) ((x) == SCM_GOOPS_UNBOUND)
119 static int goops_loaded_p
= 0;
120 static scm_t_rstate
*goops_rstate
;
122 static SCM scm_goops_lookup_closure
;
124 /* These variables are filled in by the object system when loaded. */
125 SCM scm_class_boolean
, scm_class_char
, scm_class_pair
;
126 SCM scm_class_procedure
, scm_class_string
, scm_class_symbol
;
127 SCM scm_class_procedure_with_setter
, scm_class_primitive_generic
;
128 SCM scm_class_vector
, scm_class_null
;
129 SCM scm_class_integer
, scm_class_real
, scm_class_complex
, scm_class_fraction
;
130 SCM scm_class_unknown
;
131 SCM scm_class_top
, scm_class_object
, scm_class_class
;
132 SCM scm_class_applicable
;
133 SCM scm_class_entity
, scm_class_entity_with_setter
;
134 SCM scm_class_generic
, scm_class_generic_with_setter
;
135 SCM scm_class_accessor
;
136 SCM scm_class_extended_generic
, scm_class_extended_generic_with_setter
;
137 SCM scm_class_extended_accessor
;
138 SCM scm_class_method
;
139 SCM scm_class_simple_method
, scm_class_accessor_method
;
140 SCM scm_class_procedure_class
;
141 SCM scm_class_operator_class
, scm_class_operator_with_setter_class
;
142 SCM scm_class_entity_class
;
143 SCM scm_class_number
, scm_class_list
;
144 SCM scm_class_keyword
;
145 SCM scm_class_port
, scm_class_input_output_port
;
146 SCM scm_class_input_port
, scm_class_output_port
;
147 SCM scm_class_foreign_class
, scm_class_foreign_object
;
148 SCM scm_class_foreign_slot
;
149 SCM scm_class_self
, scm_class_protected
;
150 SCM scm_class_opaque
, scm_class_read_only
;
151 SCM scm_class_protected_opaque
, scm_class_protected_read_only
;
153 SCM scm_class_int
, scm_class_float
, scm_class_double
;
155 /* Port classes. Allocate 3 times the maximum number of port types so that
156 input ports, output ports, and in/out ports can be stored at different
157 offsets. See `SCM_IN_PCLASS_INDEX' et al. */
158 SCM scm_port_class
[3 * SCM_I_MAX_PORT_TYPE_COUNT
];
161 SCM scm_smob_class
[SCM_I_MAX_SMOB_TYPE_COUNT
];
163 SCM scm_no_applicable_method
;
165 SCM_SYMBOL (scm_sym_define_public
, "define-public");
167 static SCM
scm_make_unbound (void);
168 static SCM
scm_unbound_p (SCM obj
);
169 static SCM
scm_assert_bound (SCM value
, SCM obj
);
170 static SCM
scm_at_assert_bound_ref (SCM obj
, SCM index
);
171 static SCM
scm_sys_goops_loaded (void);
173 /* This function is used for efficient type dispatch. */
174 SCM_DEFINE (scm_class_of
, "class-of", 1, 0, 0,
176 "Return the class of @var{x}.")
177 #define FUNC_NAME s_scm_class_of
179 switch (SCM_ITAG3 (x
))
183 return scm_class_integer
;
187 return scm_class_char
;
188 else if (scm_is_bool (x
))
189 return scm_class_boolean
;
190 else if (scm_is_null (x
))
191 return scm_class_null
;
193 return scm_class_unknown
;
196 switch (SCM_TYP7 (x
))
198 case scm_tcs_cons_nimcar
:
199 return scm_class_pair
;
200 case scm_tcs_closures
:
201 return scm_class_procedure
;
203 return scm_class_symbol
;
206 return scm_class_vector
;
208 return scm_class_string
;
210 switch SCM_TYP16 (x
) {
212 return scm_class_integer
;
214 return scm_class_real
;
215 case scm_tc16_complex
:
216 return scm_class_complex
;
217 case scm_tc16_fraction
:
218 return scm_class_fraction
;
228 case scm_tc7_subr_1o
:
229 case scm_tc7_subr_2o
:
230 case scm_tc7_lsubr_2
:
232 if (SCM_SUBR_GENERIC (x
) && *SCM_SUBR_GENERIC (x
))
233 return scm_class_primitive_generic
;
235 return scm_class_procedure
;
237 return scm_class_procedure
;
239 return scm_class_procedure_with_setter
;
243 scm_t_bits type
= SCM_TYP16 (x
);
244 if (type
!= scm_tc16_port_with_ps
)
245 return scm_smob_class
[SCM_TC2SMOBNUM (type
)];
246 x
= SCM_PORT_WITH_PS_PORT (x
);
247 /* fall through to ports */
250 return scm_port_class
[(SCM_WRTNG
& SCM_CELL_WORD_0 (x
)
251 ? (SCM_RDNG
& SCM_CELL_WORD_0 (x
)
252 ? SCM_INOUT_PCLASS_INDEX
| SCM_PTOBNUM (x
)
253 : SCM_OUT_PCLASS_INDEX
| SCM_PTOBNUM (x
))
254 : SCM_IN_PCLASS_INDEX
| SCM_PTOBNUM (x
))];
256 if (SCM_OBJ_CLASS_FLAGS (x
) & SCM_CLASSF_GOOPS_VALID
)
257 return SCM_CLASS_OF (x
);
258 else if (SCM_OBJ_CLASS_FLAGS (x
) & SCM_CLASSF_GOOPS
)
261 if (! scm_is_false (SCM_OBJ_CLASS_REDEF (x
)))
262 scm_change_object_class (x
,
263 SCM_CLASS_OF (x
), /* old */
264 SCM_OBJ_CLASS_REDEF (x
)); /* new */
265 return SCM_CLASS_OF (x
);
269 /* ordinary struct */
270 SCM handle
= scm_struct_create_handle (SCM_STRUCT_VTABLE (x
));
271 if (scm_is_true (SCM_STRUCT_TABLE_CLASS (SCM_CDR (handle
))))
272 return SCM_STRUCT_TABLE_CLASS (SCM_CDR (handle
));
275 SCM name
= SCM_STRUCT_TABLE_NAME (SCM_CDR (handle
));
276 SCM
class = scm_make_extended_class (scm_is_true (name
)
277 ? scm_i_symbol_chars (name
)
279 SCM_I_OPERATORP (x
));
280 SCM_SET_STRUCT_TABLE_CLASS (SCM_CDR (handle
), class);
286 return scm_class_pair
;
288 return scm_class_unknown
;
294 case scm_tc3_closure
:
298 return scm_class_unknown
;
302 /******************************************************************************
306 * This version doesn't fully handle multiple-inheritance. It serves
307 * only for booting classes and will be overloaded in Scheme
309 ******************************************************************************/
312 map (SCM (*proc
) (SCM
), SCM ls
)
314 if (scm_is_null (ls
))
318 SCM res
= scm_cons (proc (SCM_CAR (ls
)), SCM_EOL
);
321 while (!scm_is_null (ls
))
323 SCM_SETCDR (h
, scm_cons (proc (SCM_CAR (ls
)), SCM_EOL
));
335 while (!scm_is_null (ls
))
337 SCM el
= SCM_CAR (ls
);
338 if (scm_is_false (scm_c_memq (el
, res
)))
339 res
= scm_cons (el
, res
);
346 compute_cpl (SCM
class)
349 return CALL_GF1 ("compute-cpl", class);
352 SCM supers
= SCM_SLOT (class, scm_si_direct_supers
);
353 SCM ls
= scm_append (scm_acons (class, supers
,
354 map (compute_cpl
, supers
)));
355 return scm_reverse_x (filter_cpl (ls
), SCM_EOL
);
359 /******************************************************************************
363 ******************************************************************************/
366 remove_duplicate_slots (SCM l
, SCM res
, SCM slots_already_seen
)
374 if (!scm_is_symbol (tmp
))
375 scm_misc_error ("%compute-slots", "bad slot name ~S", scm_list_1 (tmp
));
377 if (scm_is_false (scm_c_memq (tmp
, slots_already_seen
))) {
378 res
= scm_cons (SCM_CAR (l
), res
);
379 slots_already_seen
= scm_cons (tmp
, slots_already_seen
);
382 return remove_duplicate_slots (SCM_CDR (l
), res
, slots_already_seen
);
386 build_slots_list (SCM dslots
, SCM cpl
)
388 register SCM res
= dslots
;
390 for (cpl
= SCM_CDR (cpl
); !scm_is_null (cpl
); cpl
= SCM_CDR (cpl
))
391 res
= scm_append (scm_list_2 (SCM_SLOT (SCM_CAR (cpl
),
392 scm_si_direct_slots
),
395 /* res contains a list of slots. Remove slots which appears more than once */
396 return remove_duplicate_slots (scm_reverse (res
), SCM_EOL
, SCM_EOL
);
403 while (!scm_is_null (ls
))
405 if (!scm_is_pair (SCM_CAR (ls
)))
406 SCM_SETCAR (ls
, scm_cons (SCM_CAR (ls
), SCM_EOL
));
413 SCM_DEFINE (scm_sys_compute_slots
, "%compute-slots", 1, 0, 0,
415 "Return a list consisting of the names of all slots belonging to\n"
416 "class @var{class}, i. e. the slots of @var{class} and of all of\n"
418 #define FUNC_NAME s_scm_sys_compute_slots
420 SCM_VALIDATE_CLASS (1, class);
421 return build_slots_list (SCM_SLOT (class, scm_si_direct_slots
),
422 SCM_SLOT (class, scm_si_cpl
));
427 /******************************************************************************
429 * compute-getters-n-setters
431 * This version doesn't handle slot options. It serves only for booting
432 * classes and will be overloaded in Scheme.
434 ******************************************************************************/
436 SCM_KEYWORD (k_init_value
, "init-value");
437 SCM_KEYWORD (k_init_thunk
, "init-thunk");
440 compute_getters_n_setters (SCM slots
)
446 for ( ; !scm_is_null (slots
); slots
= SCM_CDR (slots
))
448 SCM init
= SCM_BOOL_F
;
449 SCM options
= SCM_CDAR (slots
);
450 if (!scm_is_null (options
))
452 init
= scm_get_keyword (k_init_value
, options
, 0);
455 init
= scm_i_eval_x (scm_list_3 (scm_sym_lambda
,
457 scm_list_2 (scm_sym_quote
,
462 init
= scm_get_keyword (k_init_thunk
, options
, SCM_BOOL_F
);
464 *cdrloc
= scm_cons (scm_cons (SCM_CAAR (slots
),
466 scm_from_int (i
++))),
468 cdrloc
= SCM_CDRLOC (*cdrloc
);
473 /******************************************************************************
477 ******************************************************************************/
479 /*fixme* Manufacture keywords in advance */
481 scm_i_get_keyword (SCM key
, SCM l
, long len
, SCM default_value
, const char *subr
)
485 for (i
= 0; i
!= len
; i
+= 2)
487 SCM obj
= SCM_CAR (l
);
489 if (!scm_is_keyword (obj
))
490 scm_misc_error (subr
, "bad keyword: ~S", scm_list_1 (obj
));
491 else if (scm_is_eq (obj
, key
))
497 return default_value
;
501 SCM_DEFINE (scm_get_keyword
, "get-keyword", 3, 0, 0,
502 (SCM key
, SCM l
, SCM default_value
),
503 "Determine an associated value for the keyword @var{key} from\n"
504 "the list @var{l}. The list @var{l} has to consist of an even\n"
505 "number of elements, where, starting with the first, every\n"
506 "second element is a keyword, followed by its associated value.\n"
507 "If @var{l} does not hold a value for @var{key}, the value\n"
508 "@var{default_value} is returned.")
509 #define FUNC_NAME s_scm_get_keyword
513 SCM_ASSERT (scm_is_keyword (key
), key
, SCM_ARG1
, FUNC_NAME
);
514 len
= scm_ilength (l
);
515 if (len
< 0 || len
% 2 == 1)
516 scm_misc_error (FUNC_NAME
, "Bad keyword-value list: ~S", scm_list_1 (l
));
518 return scm_i_get_keyword (key
, l
, len
, default_value
, FUNC_NAME
);
523 SCM_KEYWORD (k_init_keyword
, "init-keyword");
525 static SCM
get_slot_value (SCM
class, SCM obj
, SCM slotdef
);
526 static SCM
set_slot_value (SCM
class, SCM obj
, SCM slotdef
, SCM value
);
528 SCM_DEFINE (scm_sys_initialize_object
, "%initialize-object", 2, 0, 0,
529 (SCM obj
, SCM initargs
),
530 "Initialize the object @var{obj} with the given arguments\n"
532 #define FUNC_NAME s_scm_sys_initialize_object
534 SCM tmp
, get_n_set
, slots
;
535 SCM
class = SCM_CLASS_OF (obj
);
538 SCM_VALIDATE_INSTANCE (1, obj
);
539 n_initargs
= scm_ilength (initargs
);
540 SCM_ASSERT ((n_initargs
& 1) == 0, initargs
, SCM_ARG2
, FUNC_NAME
);
542 get_n_set
= SCM_SLOT (class, scm_si_getters_n_setters
);
543 slots
= SCM_SLOT (class, scm_si_slots
);
545 /* See for each slot how it must be initialized */
547 !scm_is_null (slots
);
548 get_n_set
= SCM_CDR (get_n_set
), slots
= SCM_CDR (slots
))
550 SCM slot_name
= SCM_CAR (slots
);
553 if (!scm_is_null (SCM_CDR (slot_name
)))
555 /* This slot admits (perhaps) to be initialized at creation time */
556 long n
= scm_ilength (SCM_CDR (slot_name
));
557 if (n
& 1) /* odd or -1 */
558 SCM_MISC_ERROR ("class contains bogus slot definition: ~S",
559 scm_list_1 (slot_name
));
560 tmp
= scm_i_get_keyword (k_init_keyword
,
565 slot_name
= SCM_CAR (slot_name
);
568 /* an initarg was provided for this slot */
569 if (!scm_is_keyword (tmp
))
570 SCM_MISC_ERROR ("initarg must be a keyword. It was ~S",
572 slot_value
= scm_i_get_keyword (tmp
,
581 /* set slot to provided value */
582 set_slot_value (class, obj
, SCM_CAR (get_n_set
), slot_value
);
585 /* set slot to its :init-form if it exists */
586 tmp
= SCM_CADAR (get_n_set
);
587 if (scm_is_true (tmp
))
589 slot_value
= get_slot_value (class, obj
, SCM_CAR (get_n_set
));
590 if (SCM_GOOPS_UNBOUNDP (slot_value
))
592 SCM env
= SCM_EXTEND_ENV (SCM_EOL
, SCM_EOL
, SCM_ENV (tmp
));
593 set_slot_value (class,
596 scm_eval_body (SCM_CLOSURE_BODY (tmp
), env
));
606 /* NOTE: The following macros are interdependent with code
607 * in goops.scm:compute-getters-n-setters
609 #define SCM_GNS_INSTANCE_ALLOCATED_P(gns) \
610 (SCM_I_INUMP (SCM_CDDR (gns)) \
611 || (scm_is_pair (SCM_CDDR (gns)) \
612 && scm_is_pair (SCM_CDDDR (gns)) \
613 && scm_is_pair (SCM_CDDDDR (gns))))
614 #define SCM_GNS_INDEX(gns) \
615 (SCM_I_INUMP (SCM_CDDR (gns)) \
616 ? SCM_I_INUM (SCM_CDDR (gns)) \
617 : scm_to_long (SCM_CAR (SCM_CDDDDR (gns))))
618 #define SCM_GNS_SIZE(gns) \
619 (SCM_I_INUMP (SCM_CDDR (gns)) \
621 : scm_to_long (SCM_CADR (SCM_CDDDDR (gns))))
623 SCM_KEYWORD (k_class
, "class");
624 SCM_KEYWORD (k_allocation
, "allocation");
625 SCM_KEYWORD (k_instance
, "instance");
627 SCM_DEFINE (scm_sys_prep_layout_x
, "%prep-layout!", 1, 0, 0,
630 #define FUNC_NAME s_scm_sys_prep_layout_x
632 SCM slots
, getters_n_setters
, nfields
;
633 unsigned long int n
, i
;
637 SCM_VALIDATE_INSTANCE (1, class);
638 slots
= SCM_SLOT (class, scm_si_slots
);
639 getters_n_setters
= SCM_SLOT (class, scm_si_getters_n_setters
);
640 nfields
= SCM_SLOT (class, scm_si_nfields
);
641 if (!SCM_I_INUMP (nfields
) || SCM_I_INUM (nfields
) < 0)
642 SCM_MISC_ERROR ("bad value in nfields slot: ~S",
643 scm_list_1 (nfields
));
644 n
= 2 * SCM_I_INUM (nfields
);
645 if (n
< sizeof (SCM_CLASS_CLASS_LAYOUT
) - 1
646 && SCM_SUBCLASSP (class, scm_class_class
))
647 SCM_MISC_ERROR ("class object doesn't have enough fields: ~S",
648 scm_list_1 (nfields
));
650 layout
= scm_i_make_string (n
, &s
);
652 while (scm_is_pair (getters_n_setters
))
654 if (SCM_GNS_INSTANCE_ALLOCATED_P (SCM_CAR (getters_n_setters
)))
657 int len
, index
, size
;
660 if (i
>= n
|| !scm_is_pair (slots
))
663 /* extract slot type */
664 len
= scm_ilength (SCM_CDAR (slots
));
665 type
= scm_i_get_keyword (k_class
, SCM_CDAR (slots
),
666 len
, SCM_BOOL_F
, FUNC_NAME
);
667 /* determine slot GC protection and access mode */
668 if (scm_is_false (type
))
675 if (!SCM_CLASSP (type
))
676 SCM_MISC_ERROR ("bad slot class", SCM_EOL
);
677 else if (SCM_SUBCLASSP (type
, scm_class_foreign_slot
))
679 if (SCM_SUBCLASSP (type
, scm_class_self
))
681 else if (SCM_SUBCLASSP (type
, scm_class_protected
))
686 if (SCM_SUBCLASSP (type
, scm_class_opaque
))
688 else if (SCM_SUBCLASSP (type
, scm_class_read_only
))
700 index
= SCM_GNS_INDEX (SCM_CAR (getters_n_setters
));
701 if (index
!= (i
>> 1))
703 size
= SCM_GNS_SIZE (SCM_CAR (getters_n_setters
));
711 slots
= SCM_CDR (slots
);
712 getters_n_setters
= SCM_CDR (getters_n_setters
);
714 if (!scm_is_null (slots
))
717 SCM_MISC_ERROR ("inconsistent getters-n-setters", SCM_EOL
);
719 SCM_SET_SLOT (class, scm_si_layout
, scm_string_to_symbol (layout
));
720 return SCM_UNSPECIFIED
;
724 static void prep_hashsets (SCM
);
726 SCM_DEFINE (scm_sys_inherit_magic_x
, "%inherit-magic!", 2, 0, 0,
727 (SCM
class, SCM dsupers
),
729 #define FUNC_NAME s_scm_sys_inherit_magic_x
733 SCM_VALIDATE_INSTANCE (1, class);
734 while (!scm_is_null (ls
))
736 SCM_ASSERT (scm_is_pair (ls
)
737 && SCM_INSTANCEP (SCM_CAR (ls
)),
741 flags
|= SCM_CLASS_FLAGS (SCM_CAR (ls
));
744 flags
&= SCM_CLASSF_INHERIT
;
746 if (! (flags
& SCM_CLASSF_ENTITY
))
748 long n
= SCM_I_INUM (SCM_SLOT (class, scm_si_nfields
));
751 * We could avoid calling scm_gc_malloc in the allocation code
752 * (in which case the following two lines are needed). Instead
753 * we make 0-slot instances non-light, so that the light case
754 * can be handled without special cases.
757 SCM_SET_CLASS_DESTRUCTOR (class, scm_struct_free_0
);
759 if (n
> 0 && !(flags
& SCM_CLASSF_METACLASS
))
761 /* NOTE: The following depends on scm_struct_i_size. */
762 flags
|= SCM_STRUCTF_LIGHT
+ n
* sizeof (SCM
); /* use light representation */
765 SCM_SET_CLASS_FLAGS (class, flags
);
767 prep_hashsets (class);
769 return SCM_UNSPECIFIED
;
774 prep_hashsets (SCM
class)
778 for (i
= 0; i
< 7; ++i
)
779 SCM_SET_HASHSET (class, i
, scm_c_uniform32 (goops_rstate
));
782 /******************************************************************************/
785 scm_basic_basic_make_class (SCM
class, SCM name
, SCM dsupers
, SCM dslots
)
787 SCM z
, cpl
, slots
, nfields
, g_n_s
;
789 /* Allocate one instance */
790 z
= scm_make_struct (class, SCM_INUM0
, SCM_EOL
);
792 /* Initialize its slots */
793 SCM_SET_SLOT (z
, scm_si_direct_supers
, dsupers
);
794 cpl
= compute_cpl (z
);
795 slots
= build_slots_list (maplist (dslots
), cpl
);
796 nfields
= scm_from_int (scm_ilength (slots
));
797 g_n_s
= compute_getters_n_setters (slots
);
799 SCM_SET_SLOT (z
, scm_si_name
, name
);
800 SCM_SET_SLOT (z
, scm_si_direct_slots
, dslots
);
801 SCM_SET_SLOT (z
, scm_si_direct_subclasses
, SCM_EOL
);
802 SCM_SET_SLOT (z
, scm_si_direct_methods
, SCM_EOL
);
803 SCM_SET_SLOT (z
, scm_si_cpl
, cpl
);
804 SCM_SET_SLOT (z
, scm_si_slots
, slots
);
805 SCM_SET_SLOT (z
, scm_si_nfields
, nfields
);
806 SCM_SET_SLOT (z
, scm_si_getters_n_setters
, g_n_s
);
807 SCM_SET_SLOT (z
, scm_si_redefined
, SCM_BOOL_F
);
808 SCM_SET_SLOT (z
, scm_si_environment
,
809 scm_top_level_env (SCM_TOP_LEVEL_LOOKUP_CLOSURE
));
811 /* Add this class in the direct-subclasses slot of dsupers */
814 for (tmp
= dsupers
; !scm_is_null (tmp
); tmp
= SCM_CDR (tmp
))
815 SCM_SET_SLOT (SCM_CAR (tmp
), scm_si_direct_subclasses
,
816 scm_cons (z
, SCM_SLOT (SCM_CAR (tmp
),
817 scm_si_direct_subclasses
)));
820 /* Support for the underlying structs: */
821 SCM_SET_CLASS_FLAGS (z
, (class == scm_class_entity_class
822 ? (SCM_CLASSF_GOOPS_OR_VALID
823 | SCM_CLASSF_OPERATOR
825 : class == scm_class_operator_class
826 ? SCM_CLASSF_GOOPS_OR_VALID
| SCM_CLASSF_OPERATOR
827 : SCM_CLASSF_GOOPS_OR_VALID
));
832 scm_basic_make_class (SCM
class, SCM name
, SCM dsupers
, SCM dslots
)
834 SCM z
= scm_basic_basic_make_class (class, name
, dsupers
, dslots
);
835 scm_sys_inherit_magic_x (z
, dsupers
);
836 scm_sys_prep_layout_x (z
);
840 /******************************************************************************/
842 SCM_SYMBOL (sym_layout
, "layout");
843 SCM_SYMBOL (sym_vcell
, "vcell");
844 SCM_SYMBOL (sym_vtable
, "vtable");
845 SCM_SYMBOL (sym_print
, "print");
846 SCM_SYMBOL (sym_procedure
, "procedure");
847 SCM_SYMBOL (sym_setter
, "setter");
848 SCM_SYMBOL (sym_redefined
, "redefined");
849 SCM_SYMBOL (sym_h0
, "h0");
850 SCM_SYMBOL (sym_h1
, "h1");
851 SCM_SYMBOL (sym_h2
, "h2");
852 SCM_SYMBOL (sym_h3
, "h3");
853 SCM_SYMBOL (sym_h4
, "h4");
854 SCM_SYMBOL (sym_h5
, "h5");
855 SCM_SYMBOL (sym_h6
, "h6");
856 SCM_SYMBOL (sym_h7
, "h7");
857 SCM_SYMBOL (sym_name
, "name");
858 SCM_SYMBOL (sym_direct_supers
, "direct-supers");
859 SCM_SYMBOL (sym_direct_slots
, "direct-slots");
860 SCM_SYMBOL (sym_direct_subclasses
, "direct-subclasses");
861 SCM_SYMBOL (sym_direct_methods
, "direct-methods");
862 SCM_SYMBOL (sym_cpl
, "cpl");
863 SCM_SYMBOL (sym_default_slot_definition_class
, "default-slot-definition-class");
864 SCM_SYMBOL (sym_slots
, "slots");
865 SCM_SYMBOL (sym_getters_n_setters
, "getters-n-setters");
866 SCM_SYMBOL (sym_keyword_access
, "keyword-access");
867 SCM_SYMBOL (sym_nfields
, "nfields");
868 SCM_SYMBOL (sym_environment
, "environment");
872 build_class_class_slots ()
875 scm_list_3 (sym_layout
, k_class
, scm_class_protected_read_only
),
876 scm_list_3 (sym_vtable
, k_class
, scm_class_self
),
877 scm_list_1 (sym_print
),
878 scm_list_3 (sym_procedure
, k_class
, scm_class_protected_opaque
),
879 scm_list_3 (sym_setter
, k_class
, scm_class_protected_opaque
),
880 scm_list_1 (sym_redefined
),
881 scm_list_3 (sym_h0
, k_class
, scm_class_int
),
882 scm_list_3 (sym_h1
, k_class
, scm_class_int
),
883 scm_list_3 (sym_h2
, k_class
, scm_class_int
),
884 scm_list_3 (sym_h3
, k_class
, scm_class_int
),
885 scm_list_3 (sym_h4
, k_class
, scm_class_int
),
886 scm_list_3 (sym_h5
, k_class
, scm_class_int
),
887 scm_list_3 (sym_h6
, k_class
, scm_class_int
),
888 scm_list_3 (sym_h7
, k_class
, scm_class_int
),
889 scm_list_1 (sym_name
),
890 scm_list_1 (sym_direct_supers
),
891 scm_list_1 (sym_direct_slots
),
892 scm_list_1 (sym_direct_subclasses
),
893 scm_list_1 (sym_direct_methods
),
894 scm_list_1 (sym_cpl
),
895 scm_list_1 (sym_default_slot_definition_class
),
896 scm_list_1 (sym_slots
),
897 scm_list_1 (sym_getters_n_setters
),
898 scm_list_1 (sym_keyword_access
),
899 scm_list_1 (sym_nfields
),
900 scm_list_1 (sym_environment
),
905 create_basic_classes (void)
907 /* SCM slots_of_class = build_class_class_slots (); */
909 /**** <scm_class_class> ****/
910 SCM cs
= scm_from_locale_string (SCM_CLASS_CLASS_LAYOUT
911 + 2 * scm_vtable_offset_user
);
912 SCM name
= scm_from_locale_symbol ("<class>");
913 scm_class_class
= scm_permanent_object (scm_make_vtable_vtable (cs
,
916 SCM_SET_CLASS_FLAGS (scm_class_class
, (SCM_CLASSF_GOOPS_OR_VALID
917 | SCM_CLASSF_METACLASS
));
919 SCM_SET_SLOT (scm_class_class
, scm_si_name
, name
);
920 SCM_SET_SLOT (scm_class_class
, scm_si_direct_supers
, SCM_EOL
); /* will be changed */
921 /* SCM_SET_SLOT (scm_class_class, scm_si_direct_slots, slots_of_class); */
922 SCM_SET_SLOT (scm_class_class
, scm_si_direct_subclasses
, SCM_EOL
);
923 SCM_SET_SLOT (scm_class_class
, scm_si_direct_methods
, SCM_EOL
);
924 SCM_SET_SLOT (scm_class_class
, scm_si_cpl
, SCM_EOL
); /* will be changed */
925 /* SCM_SET_SLOT (scm_class_class, scm_si_slots, slots_of_class); */
926 SCM_SET_SLOT (scm_class_class
, scm_si_nfields
, scm_from_int (SCM_N_CLASS_SLOTS
));
927 /* SCM_SET_SLOT (scm_class_class, scm_si_getters_n_setters,
928 compute_getters_n_setters (slots_of_class)); */
929 SCM_SET_SLOT (scm_class_class
, scm_si_redefined
, SCM_BOOL_F
);
930 SCM_SET_SLOT (scm_class_class
, scm_si_environment
,
931 scm_top_level_env (SCM_TOP_LEVEL_LOOKUP_CLOSURE
));
933 prep_hashsets (scm_class_class
);
935 DEFVAR(name
, scm_class_class
);
937 /**** <scm_class_top> ****/
938 name
= scm_from_locale_symbol ("<top>");
939 scm_class_top
= scm_permanent_object (scm_basic_make_class (scm_class_class
,
944 DEFVAR(name
, scm_class_top
);
946 /**** <scm_class_object> ****/
947 name
= scm_from_locale_symbol ("<object>");
948 scm_class_object
= scm_permanent_object (scm_basic_make_class (scm_class_class
,
950 scm_list_1 (scm_class_top
),
953 DEFVAR (name
, scm_class_object
);
955 /* <top> <object> and <class> were partially initialized. Correct them here */
956 SCM_SET_SLOT (scm_class_object
, scm_si_direct_subclasses
, scm_list_1 (scm_class_class
));
958 SCM_SET_SLOT (scm_class_class
, scm_si_direct_supers
, scm_list_1 (scm_class_object
));
959 SCM_SET_SLOT (scm_class_class
, scm_si_cpl
, scm_list_3 (scm_class_class
, scm_class_object
, scm_class_top
));
962 /******************************************************************************/
964 SCM_DEFINE (scm_instance_p
, "instance?", 1, 0, 0,
966 "Return @code{#t} if @var{obj} is an instance.")
967 #define FUNC_NAME s_scm_instance_p
969 return scm_from_bool (SCM_INSTANCEP (obj
));
974 /******************************************************************************
976 * Meta object accessors
978 ******************************************************************************/
979 SCM_DEFINE (scm_class_name
, "class-name", 1, 0, 0,
981 "Return the class name of @var{obj}.")
982 #define FUNC_NAME s_scm_class_name
984 SCM_VALIDATE_CLASS (1, obj
);
985 return scm_slot_ref (obj
, sym_name
);
989 SCM_DEFINE (scm_class_direct_supers
, "class-direct-supers", 1, 0, 0,
991 "Return the direct superclasses of the class @var{obj}.")
992 #define FUNC_NAME s_scm_class_direct_supers
994 SCM_VALIDATE_CLASS (1, obj
);
995 return scm_slot_ref (obj
, sym_direct_supers
);
999 SCM_DEFINE (scm_class_direct_slots
, "class-direct-slots", 1, 0, 0,
1001 "Return the direct slots of the class @var{obj}.")
1002 #define FUNC_NAME s_scm_class_direct_slots
1004 SCM_VALIDATE_CLASS (1, obj
);
1005 return scm_slot_ref (obj
, sym_direct_slots
);
1009 SCM_DEFINE (scm_class_direct_subclasses
, "class-direct-subclasses", 1, 0, 0,
1011 "Return the direct subclasses of the class @var{obj}.")
1012 #define FUNC_NAME s_scm_class_direct_subclasses
1014 SCM_VALIDATE_CLASS (1, obj
);
1015 return scm_slot_ref(obj
, sym_direct_subclasses
);
1019 SCM_DEFINE (scm_class_direct_methods
, "class-direct-methods", 1, 0, 0,
1021 "Return the direct methods of the class @var{obj}")
1022 #define FUNC_NAME s_scm_class_direct_methods
1024 SCM_VALIDATE_CLASS (1, obj
);
1025 return scm_slot_ref (obj
, sym_direct_methods
);
1029 SCM_DEFINE (scm_class_precedence_list
, "class-precedence-list", 1, 0, 0,
1031 "Return the class precedence list of the class @var{obj}.")
1032 #define FUNC_NAME s_scm_class_precedence_list
1034 SCM_VALIDATE_CLASS (1, obj
);
1035 return scm_slot_ref (obj
, sym_cpl
);
1039 SCM_DEFINE (scm_class_slots
, "class-slots", 1, 0, 0,
1041 "Return the slot list of the class @var{obj}.")
1042 #define FUNC_NAME s_scm_class_slots
1044 SCM_VALIDATE_CLASS (1, obj
);
1045 return scm_slot_ref (obj
, sym_slots
);
1049 SCM_DEFINE (scm_class_environment
, "class-environment", 1, 0, 0,
1051 "Return the environment of the class @var{obj}.")
1052 #define FUNC_NAME s_scm_class_environment
1054 SCM_VALIDATE_CLASS (1, obj
);
1055 return scm_slot_ref(obj
, sym_environment
);
1060 SCM_DEFINE (scm_generic_function_name
, "generic-function-name", 1, 0, 0,
1062 "Return the name of the generic function @var{obj}.")
1063 #define FUNC_NAME s_scm_generic_function_name
1065 SCM_VALIDATE_GENERIC (1, obj
);
1066 return scm_procedure_property (obj
, scm_sym_name
);
1070 SCM_SYMBOL (sym_methods
, "methods");
1071 SCM_SYMBOL (sym_extended_by
, "extended-by");
1072 SCM_SYMBOL (sym_extends
, "extends");
1075 SCM
fold_downward_gf_methods (SCM method_lists
, SCM gf
)
1077 SCM gfs
= scm_slot_ref (gf
, sym_extended_by
);
1078 method_lists
= scm_cons (scm_slot_ref (gf
, sym_methods
), method_lists
);
1079 while (!scm_is_null (gfs
))
1081 method_lists
= fold_downward_gf_methods (method_lists
, SCM_CAR (gfs
));
1082 gfs
= SCM_CDR (gfs
);
1084 return method_lists
;
1088 SCM
fold_upward_gf_methods (SCM method_lists
, SCM gf
)
1090 if (SCM_IS_A_P (gf
, scm_class_extended_generic
))
1092 SCM gfs
= scm_slot_ref (gf
, sym_extends
);
1093 while (!scm_is_null (gfs
))
1095 SCM methods
= scm_slot_ref (SCM_CAR (gfs
), sym_methods
);
1096 method_lists
= fold_upward_gf_methods (scm_cons (methods
,
1099 gfs
= SCM_CDR (gfs
);
1102 return method_lists
;
1105 SCM_DEFINE (scm_generic_function_methods
, "generic-function-methods", 1, 0, 0,
1107 "Return the methods of the generic function @var{obj}.")
1108 #define FUNC_NAME s_scm_generic_function_methods
1111 SCM_VALIDATE_GENERIC (1, obj
);
1112 methods
= fold_upward_gf_methods (SCM_EOL
, obj
);
1113 methods
= fold_downward_gf_methods (methods
, obj
);
1114 return scm_append (methods
);
1118 SCM_DEFINE (scm_method_generic_function
, "method-generic-function", 1, 0, 0,
1120 "Return the generic function for the method @var{obj}.")
1121 #define FUNC_NAME s_scm_method_generic_function
1123 SCM_VALIDATE_METHOD (1, obj
);
1124 return scm_slot_ref (obj
, scm_from_locale_symbol ("generic-function"));
1128 SCM_DEFINE (scm_method_specializers
, "method-specializers", 1, 0, 0,
1130 "Return specializers of the method @var{obj}.")
1131 #define FUNC_NAME s_scm_method_specializers
1133 SCM_VALIDATE_METHOD (1, obj
);
1134 return scm_slot_ref (obj
, scm_from_locale_symbol ("specializers"));
1138 SCM_DEFINE (scm_method_procedure
, "method-procedure", 1, 0, 0,
1140 "Return the procedure of the method @var{obj}.")
1141 #define FUNC_NAME s_scm_method_procedure
1143 SCM_VALIDATE_METHOD (1, obj
);
1144 return scm_slot_ref (obj
, sym_procedure
);
1148 SCM_DEFINE (scm_accessor_method_slot_definition
, "accessor-method-slot-definition", 1, 0, 0,
1150 "Return the slot definition of the accessor @var{obj}.")
1151 #define FUNC_NAME s_scm_accessor_method_slot_definition
1153 SCM_VALIDATE_ACCESSOR (1, obj
);
1154 return scm_slot_ref (obj
, scm_from_locale_symbol ("slot-definition"));
1158 SCM_DEFINE (scm_sys_tag_body
, "%tag-body", 1, 0, 0,
1160 "Internal GOOPS magic---don't use this function!")
1161 #define FUNC_NAME s_scm_sys_tag_body
1163 return scm_cons (SCM_IM_LAMBDA
, body
);
1167 /******************************************************************************
1169 * S l o t a c c e s s
1171 ******************************************************************************/
1173 SCM_DEFINE (scm_make_unbound
, "make-unbound", 0, 0, 0,
1175 "Return the unbound value.")
1176 #define FUNC_NAME s_scm_make_unbound
1178 return SCM_GOOPS_UNBOUND
;
1182 SCM_DEFINE (scm_unbound_p
, "unbound?", 1, 0, 0,
1184 "Return @code{#t} if @var{obj} is unbound.")
1185 #define FUNC_NAME s_scm_unbound_p
1187 return SCM_GOOPS_UNBOUNDP (obj
) ? SCM_BOOL_T
: SCM_BOOL_F
;
1191 SCM_DEFINE (scm_assert_bound
, "assert-bound", 2, 0, 0,
1192 (SCM value
, SCM obj
),
1193 "Return @var{value} if it is bound, and invoke the\n"
1194 "@var{slot-unbound} method of @var{obj} if it is not.")
1195 #define FUNC_NAME s_scm_assert_bound
1197 if (SCM_GOOPS_UNBOUNDP (value
))
1198 return CALL_GF1 ("slot-unbound", obj
);
1203 SCM_DEFINE (scm_at_assert_bound_ref
, "@assert-bound-ref", 2, 0, 0,
1204 (SCM obj
, SCM index
),
1205 "Like @code{assert-bound}, but use @var{index} for accessing\n"
1206 "the value from @var{obj}.")
1207 #define FUNC_NAME s_scm_at_assert_bound_ref
1209 SCM value
= SCM_SLOT (obj
, scm_to_int (index
));
1210 if (SCM_GOOPS_UNBOUNDP (value
))
1211 return CALL_GF1 ("slot-unbound", obj
);
1216 SCM_DEFINE (scm_sys_fast_slot_ref
, "%fast-slot-ref", 2, 0, 0,
1217 (SCM obj
, SCM index
),
1218 "Return the slot value with index @var{index} from @var{obj}.")
1219 #define FUNC_NAME s_scm_sys_fast_slot_ref
1221 unsigned long int i
;
1223 SCM_VALIDATE_INSTANCE (1, obj
);
1224 i
= scm_to_unsigned_integer (index
, 0,
1225 SCM_I_INUM (SCM_SLOT (SCM_CLASS_OF (obj
),
1228 return SCM_SLOT (obj
, i
);
1232 SCM_DEFINE (scm_sys_fast_slot_set_x
, "%fast-slot-set!", 3, 0, 0,
1233 (SCM obj
, SCM index
, SCM value
),
1234 "Set the slot with index @var{index} in @var{obj} to\n"
1236 #define FUNC_NAME s_scm_sys_fast_slot_set_x
1238 unsigned long int i
;
1240 SCM_VALIDATE_INSTANCE (1, obj
);
1241 i
= scm_to_unsigned_integer (index
, 0,
1242 SCM_I_INUM (SCM_SLOT (SCM_CLASS_OF (obj
),
1246 SCM_SET_SLOT (obj
, i
, value
);
1248 return SCM_UNSPECIFIED
;
1253 SCM_SYNTAX (s_atslot_ref
, "@slot-ref", scm_i_makbimacro
, scm_m_atslot_ref
);
1254 SCM_SYNTAX (s_atslot_set_x
, "@slot-set!", scm_i_makbimacro
, scm_m_atslot_set_x
);
1259 /* In the future, this function will return the effective slot
1260 * definition associated with SLOT_NAME. Now it just returns some of
1261 * the information which will be stored in the effective slot
1266 slot_definition_using_name (SCM
class, SCM slot_name
)
1268 register SCM slots
= SCM_SLOT (class, scm_si_getters_n_setters
);
1269 for (; !scm_is_null (slots
); slots
= SCM_CDR (slots
))
1270 if (SCM_CAAR (slots
) == slot_name
)
1271 return SCM_CAR (slots
);
1276 get_slot_value (SCM
class SCM_UNUSED
, SCM obj
, SCM slotdef
)
1277 #define FUNC_NAME "%get-slot-value"
1279 SCM access
= SCM_CDDR (slotdef
);
1281 * - access is an integer (the offset of this slot in the slots vector)
1282 * - otherwise (car access) is the getter function to apply
1284 * Instances have never more than SCM_MOST_POSITIVE_FIXNUM slots, so
1285 * we can just assume fixnums here.
1287 if (SCM_I_INUMP (access
))
1288 /* Don't poke at the slots directly, because scm_struct_ref handles the
1289 access bits for us. */
1290 return scm_struct_ref (obj
, access
);
1293 /* We must evaluate (apply (car access) (list obj))
1294 * where (car access) is known to be a closure of arity 1 */
1295 register SCM code
, env
;
1297 code
= SCM_CAR (access
);
1298 if (!SCM_CLOSUREP (code
))
1299 return SCM_SUBRF (code
) (obj
);
1300 env
= SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (code
),
1303 /* Evaluate the closure body */
1304 return scm_eval_body (SCM_CLOSURE_BODY (code
), env
);
1310 get_slot_value_using_name (SCM
class, SCM obj
, SCM slot_name
)
1312 SCM slotdef
= slot_definition_using_name (class, slot_name
);
1313 if (scm_is_true (slotdef
))
1314 return get_slot_value (class, obj
, slotdef
);
1316 return CALL_GF3 ("slot-missing", class, obj
, slot_name
);
1320 set_slot_value (SCM
class SCM_UNUSED
, SCM obj
, SCM slotdef
, SCM value
)
1321 #define FUNC_NAME "%set-slot-value"
1323 SCM access
= SCM_CDDR (slotdef
);
1325 * - access is an integer (the offset of this slot in the slots vector)
1326 * - otherwise (cadr access) is the setter function to apply
1328 * Instances have never more than SCM_MOST_POSITIVE_FIXNUM slots, so
1329 * we can just assume fixnums here.
1331 if (SCM_I_INUMP (access
))
1332 /* obey permissions bits via going through struct-set! */
1333 scm_struct_set_x (obj
, access
, value
);
1336 /* We must evaluate (apply (cadr l) (list obj value))
1337 * where (cadr l) is known to be a closure of arity 2 */
1338 register SCM code
, env
;
1340 code
= SCM_CADR (access
);
1341 if (!SCM_CLOSUREP (code
))
1342 SCM_SUBRF (code
) (obj
, value
);
1345 env
= SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (code
),
1346 scm_list_2 (obj
, value
),
1348 /* Evaluate the closure body */
1349 scm_eval_body (SCM_CLOSURE_BODY (code
), env
);
1352 return SCM_UNSPECIFIED
;
1357 set_slot_value_using_name (SCM
class, SCM obj
, SCM slot_name
, SCM value
)
1359 SCM slotdef
= slot_definition_using_name (class, slot_name
);
1360 if (scm_is_true (slotdef
))
1361 return set_slot_value (class, obj
, slotdef
, value
);
1363 return CALL_GF4 ("slot-missing", class, obj
, slot_name
, value
);
1367 test_slot_existence (SCM
class SCM_UNUSED
, SCM obj
, SCM slot_name
)
1371 for (l
= SCM_ACCESSORS_OF (obj
); !scm_is_null (l
); l
= SCM_CDR (l
))
1372 if (scm_is_eq (SCM_CAAR (l
), slot_name
))
1378 /* ======================================== */
1380 SCM_DEFINE (scm_slot_ref_using_class
, "slot-ref-using-class", 3, 0, 0,
1381 (SCM
class, SCM obj
, SCM slot_name
),
1383 #define FUNC_NAME s_scm_slot_ref_using_class
1387 SCM_VALIDATE_CLASS (1, class);
1388 SCM_VALIDATE_INSTANCE (2, obj
);
1389 SCM_VALIDATE_SYMBOL (3, slot_name
);
1391 res
= get_slot_value_using_name (class, obj
, slot_name
);
1392 if (SCM_GOOPS_UNBOUNDP (res
))
1393 return CALL_GF3 ("slot-unbound", class, obj
, slot_name
);
1399 SCM_DEFINE (scm_slot_set_using_class_x
, "slot-set-using-class!", 4, 0, 0,
1400 (SCM
class, SCM obj
, SCM slot_name
, SCM value
),
1402 #define FUNC_NAME s_scm_slot_set_using_class_x
1404 SCM_VALIDATE_CLASS (1, class);
1405 SCM_VALIDATE_INSTANCE (2, obj
);
1406 SCM_VALIDATE_SYMBOL (3, slot_name
);
1408 return set_slot_value_using_name (class, obj
, slot_name
, value
);
1413 SCM_DEFINE (scm_slot_bound_using_class_p
, "slot-bound-using-class?", 3, 0, 0,
1414 (SCM
class, SCM obj
, SCM slot_name
),
1416 #define FUNC_NAME s_scm_slot_bound_using_class_p
1418 SCM_VALIDATE_CLASS (1, class);
1419 SCM_VALIDATE_INSTANCE (2, obj
);
1420 SCM_VALIDATE_SYMBOL (3, slot_name
);
1422 return (SCM_GOOPS_UNBOUNDP (get_slot_value_using_name (class, obj
, slot_name
))
1428 SCM_DEFINE (scm_slot_exists_using_class_p
, "slot-exists-using-class?", 3, 0, 0,
1429 (SCM
class, SCM obj
, SCM slot_name
),
1431 #define FUNC_NAME s_scm_slot_exists_using_class_p
1433 SCM_VALIDATE_CLASS (1, class);
1434 SCM_VALIDATE_INSTANCE (2, obj
);
1435 SCM_VALIDATE_SYMBOL (3, slot_name
);
1436 return test_slot_existence (class, obj
, slot_name
);
1441 /* ======================================== */
1443 SCM_DEFINE (scm_slot_ref
, "slot-ref", 2, 0, 0,
1444 (SCM obj
, SCM slot_name
),
1445 "Return the value from @var{obj}'s slot with the name\n"
1447 #define FUNC_NAME s_scm_slot_ref
1451 SCM_VALIDATE_INSTANCE (1, obj
);
1452 TEST_CHANGE_CLASS (obj
, class);
1454 res
= get_slot_value_using_name (class, obj
, slot_name
);
1455 if (SCM_GOOPS_UNBOUNDP (res
))
1456 return CALL_GF3 ("slot-unbound", class, obj
, slot_name
);
1461 SCM_DEFINE (scm_slot_set_x
, "slot-set!", 3, 0, 0,
1462 (SCM obj
, SCM slot_name
, SCM value
),
1463 "Set the slot named @var{slot_name} of @var{obj} to @var{value}.")
1464 #define FUNC_NAME s_scm_slot_set_x
1468 SCM_VALIDATE_INSTANCE (1, obj
);
1469 TEST_CHANGE_CLASS(obj
, class);
1471 return set_slot_value_using_name (class, obj
, slot_name
, value
);
1475 const char *scm_s_slot_set_x
= s_scm_slot_set_x
;
1477 SCM_DEFINE (scm_slot_bound_p
, "slot-bound?", 2, 0, 0,
1478 (SCM obj
, SCM slot_name
),
1479 "Return @code{#t} if the slot named @var{slot_name} of @var{obj}\n"
1481 #define FUNC_NAME s_scm_slot_bound_p
1485 SCM_VALIDATE_INSTANCE (1, obj
);
1486 TEST_CHANGE_CLASS(obj
, class);
1488 return (SCM_GOOPS_UNBOUNDP (get_slot_value_using_name (class,
1496 SCM_DEFINE (scm_slot_exists_p
, "slot-exists?", 2, 0, 0,
1497 (SCM obj
, SCM slot_name
),
1498 "Return @code{#t} if @var{obj} has a slot named @var{slot_name}.")
1499 #define FUNC_NAME s_scm_slot_exists_p
1503 SCM_VALIDATE_INSTANCE (1, obj
);
1504 SCM_VALIDATE_SYMBOL (2, slot_name
);
1505 TEST_CHANGE_CLASS (obj
, class);
1507 return test_slot_existence (class, obj
, slot_name
);
1512 /******************************************************************************
1514 * %allocate-instance (the low level instance allocation primitive)
1516 ******************************************************************************/
1518 static void clear_method_cache (SCM
);
1521 wrap_init (SCM
class, SCM
*m
, long n
)
1524 scm_t_bits slayout
= SCM_STRUCT_DATA (class)[scm_vtable_index_layout
];
1525 const char *layout
= scm_i_symbol_chars (SCM_PACK (slayout
));
1527 /* Set all SCM-holding slots to unbound */
1528 for (i
= 0; i
< n
; i
++)
1529 if (layout
[i
*2] == 'p')
1530 m
[i
] = SCM_GOOPS_UNBOUND
;
1534 return scm_double_cell ((((scm_t_bits
) SCM_STRUCT_DATA (class))
1536 (scm_t_bits
) m
, 0, 0);
1539 SCM_DEFINE (scm_sys_allocate_instance
, "%allocate-instance", 2, 0, 0,
1540 (SCM
class, SCM initargs
),
1541 "Create a new instance of class @var{class} and initialize it\n"
1542 "from the arguments @var{initargs}.")
1543 #define FUNC_NAME s_scm_sys_allocate_instance
1548 SCM_VALIDATE_CLASS (1, class);
1550 /* Most instances */
1551 if (SCM_CLASS_FLAGS (class) & SCM_STRUCTF_LIGHT
)
1553 n
= SCM_I_INUM (SCM_SLOT (class, scm_si_nfields
));
1554 m
= (SCM
*) scm_gc_malloc (n
* sizeof (SCM
), "struct");
1555 return wrap_init (class, m
, n
);
1558 /* Foreign objects */
1559 if (SCM_CLASS_FLAGS (class) & SCM_CLASSF_FOREIGN
)
1560 return scm_make_foreign_object (class, initargs
);
1562 n
= SCM_I_INUM (SCM_SLOT (class, scm_si_nfields
));
1565 if (SCM_CLASS_FLAGS (class) & SCM_CLASSF_ENTITY
)
1567 m
= (SCM
*) scm_alloc_struct (n
, scm_struct_entity_n_extra_words
,
1569 m
[scm_struct_i_setter
] = SCM_BOOL_F
;
1570 m
[scm_struct_i_procedure
] = SCM_BOOL_F
;
1571 /* Generic functions */
1572 if (SCM_CLASS_FLAGS (class) & SCM_CLASSF_PURE_GENERIC
)
1574 SCM gf
= wrap_init (class, m
, n
);
1575 clear_method_cache (gf
);
1579 return wrap_init (class, m
, n
);
1583 if (SCM_CLASS_FLAGS (class) & SCM_CLASSF_METACLASS
)
1587 /* allocate class object */
1588 SCM z
= scm_make_struct (class, SCM_INUM0
, SCM_EOL
);
1590 SCM_SET_SLOT (z
, scm_si_print
, SCM_GOOPS_UNBOUND
);
1591 for (i
= scm_si_goops_fields
; i
< n
; i
++)
1592 SCM_SET_SLOT (z
, i
, SCM_GOOPS_UNBOUND
);
1594 if (SCM_SUBCLASSP (class, scm_class_entity_class
))
1595 SCM_SET_CLASS_FLAGS (z
, SCM_CLASSF_OPERATOR
| SCM_CLASSF_ENTITY
);
1596 else if (SCM_SUBCLASSP (class, scm_class_operator_class
))
1597 SCM_SET_CLASS_FLAGS (z
, SCM_CLASSF_OPERATOR
);
1602 /* Non-light instances */
1604 m
= (SCM
*) scm_alloc_struct (n
, scm_struct_n_extra_words
, "heavy struct");
1605 return wrap_init (class, m
, n
);
1610 SCM_DEFINE (scm_sys_set_object_setter_x
, "%set-object-setter!", 2, 0, 0,
1611 (SCM obj
, SCM setter
),
1613 #define FUNC_NAME s_scm_sys_set_object_setter_x
1615 SCM_ASSERT (SCM_STRUCTP (obj
)
1616 && ((SCM_CLASS_FLAGS (obj
) & SCM_CLASSF_OPERATOR
)
1617 || SCM_I_ENTITYP (obj
)),
1621 if (SCM_I_ENTITYP (obj
))
1622 SCM_SET_ENTITY_SETTER (obj
, setter
);
1624 SCM_OPERATOR_CLASS (obj
)->setter
= setter
;
1625 return SCM_UNSPECIFIED
;
1629 /******************************************************************************
1631 * %modify-instance (used by change-class to modify in place)
1633 ******************************************************************************/
1635 SCM_DEFINE (scm_sys_modify_instance
, "%modify-instance", 2, 0, 0,
1638 #define FUNC_NAME s_scm_sys_modify_instance
1640 SCM_VALIDATE_INSTANCE (1, old
);
1641 SCM_VALIDATE_INSTANCE (2, new);
1643 /* Exchange the data contained in old and new. We exchange rather than
1644 * scratch the old value with new to be correct with GC.
1645 * See "Class redefinition protocol above".
1647 SCM_CRITICAL_SECTION_START
;
1649 SCM car
= SCM_CAR (old
);
1650 SCM cdr
= SCM_CDR (old
);
1651 SCM_SETCAR (old
, SCM_CAR (new));
1652 SCM_SETCDR (old
, SCM_CDR (new));
1653 SCM_SETCAR (new, car
);
1654 SCM_SETCDR (new, cdr
);
1656 SCM_CRITICAL_SECTION_END
;
1657 return SCM_UNSPECIFIED
;
1661 SCM_DEFINE (scm_sys_modify_class
, "%modify-class", 2, 0, 0,
1664 #define FUNC_NAME s_scm_sys_modify_class
1666 SCM_VALIDATE_CLASS (1, old
);
1667 SCM_VALIDATE_CLASS (2, new);
1669 SCM_CRITICAL_SECTION_START
;
1671 SCM car
= SCM_CAR (old
);
1672 SCM cdr
= SCM_CDR (old
);
1673 SCM_SETCAR (old
, SCM_CAR (new));
1674 SCM_SETCDR (old
, SCM_CDR (new));
1675 SCM_STRUCT_DATA (old
)[scm_vtable_index_vtable
] = SCM_UNPACK (old
);
1676 SCM_SETCAR (new, car
);
1677 SCM_SETCDR (new, cdr
);
1678 SCM_STRUCT_DATA (new)[scm_vtable_index_vtable
] = SCM_UNPACK (new);
1680 SCM_CRITICAL_SECTION_END
;
1681 return SCM_UNSPECIFIED
;
1685 SCM_DEFINE (scm_sys_invalidate_class
, "%invalidate-class", 1, 0, 0,
1688 #define FUNC_NAME s_scm_sys_invalidate_class
1690 SCM_VALIDATE_CLASS (1, class);
1691 SCM_CLEAR_CLASS_FLAGS (class, SCM_CLASSF_GOOPS_VALID
);
1692 return SCM_UNSPECIFIED
;
1696 /* When instances change class, they finally get a new body, but
1697 * before that, they go through purgatory in hell. Odd as it may
1698 * seem, this data structure saves us from eternal suffering in
1699 * infinite recursions.
1702 static scm_t_bits
**hell
;
1703 static long n_hell
= 1; /* one place for the evil one himself */
1704 static long hell_size
= 4;
1705 static SCM hell_mutex
;
1711 for (i
= 1; i
< n_hell
; ++i
)
1712 if (SCM_STRUCT_DATA (o
) == hell
[i
])
1718 go_to_hell (void *o
)
1720 SCM obj
= SCM_PACK ((scm_t_bits
) o
);
1721 scm_lock_mutex (hell_mutex
);
1722 if (n_hell
>= hell_size
)
1725 hell
= scm_realloc (hell
, hell_size
* sizeof(*hell
));
1727 hell
[n_hell
++] = SCM_STRUCT_DATA (obj
);
1728 scm_unlock_mutex (hell_mutex
);
1732 go_to_heaven (void *o
)
1734 scm_lock_mutex (hell_mutex
);
1735 hell
[burnin (SCM_PACK ((scm_t_bits
) o
))] = hell
[--n_hell
];
1736 scm_unlock_mutex (hell_mutex
);
1740 SCM_SYMBOL (scm_sym_change_class
, "change-class");
1743 purgatory (void *args
)
1745 return scm_apply_0 (GETVAR (scm_sym_change_class
),
1746 SCM_PACK ((scm_t_bits
) args
));
1749 /* This function calls the generic function change-class for all
1750 * instances which aren't currently undergoing class change.
1754 scm_change_object_class (SCM obj
, SCM old_class SCM_UNUSED
, SCM new_class
)
1757 scm_internal_dynamic_wind (go_to_hell
, purgatory
, go_to_heaven
,
1758 (void *) SCM_UNPACK (scm_list_2 (obj
, new_class
)),
1759 (void *) SCM_UNPACK (obj
));
1762 /******************************************************************************
1768 * GGG E N E R I C F U N C T I O N S
1770 * This implementation provides
1771 * - generic functions (with class specializers)
1774 * - a hard-coded MOP for standard gf, which can be overloaded for non-std gf
1776 ******************************************************************************/
1778 SCM_KEYWORD (k_name
, "name");
1780 SCM_SYMBOL (sym_no_method
, "no-method");
1782 static SCM list_of_no_method
;
1784 SCM_GLOBAL_SYMBOL (scm_sym_args
, "args");
1788 scm_make_method_cache (SCM gf
)
1790 return scm_list_5 (SCM_IM_DISPATCH
,
1793 scm_c_make_vector (SCM_INITIAL_MCACHE_SIZE
,
1799 clear_method_cache (SCM gf
)
1801 SCM cache
= scm_make_method_cache (gf
);
1802 SCM_SET_ENTITY_PROCEDURE (gf
, cache
);
1803 SCM_SET_SLOT (gf
, scm_si_used_by
, SCM_BOOL_F
);
1806 SCM_DEFINE (scm_sys_invalidate_method_cache_x
, "%invalidate-method-cache!", 1, 0, 0,
1809 #define FUNC_NAME s_scm_sys_invalidate_method_cache_x
1812 SCM_ASSERT (SCM_PUREGENERICP (gf
), gf
, SCM_ARG1
, FUNC_NAME
);
1813 used_by
= SCM_SLOT (gf
, scm_si_used_by
);
1814 if (scm_is_true (used_by
))
1816 SCM methods
= SCM_SLOT (gf
, scm_si_methods
);
1817 for (; scm_is_pair (used_by
); used_by
= SCM_CDR (used_by
))
1818 scm_sys_invalidate_method_cache_x (SCM_CAR (used_by
));
1819 clear_method_cache (gf
);
1820 for (; scm_is_pair (methods
); methods
= SCM_CDR (methods
))
1821 SCM_SET_SLOT (SCM_CAR (methods
), scm_si_code_table
, SCM_EOL
);
1824 SCM n
= SCM_SLOT (gf
, scm_si_n_specialized
);
1825 /* The sign of n is a flag indicating rest args. */
1826 SCM_SET_MCACHE_N_SPECIALIZED (SCM_ENTITY_PROCEDURE (gf
), n
);
1828 return SCM_UNSPECIFIED
;
1832 SCM_DEFINE (scm_generic_capability_p
, "generic-capability?", 1, 0, 0,
1835 #define FUNC_NAME s_scm_generic_capability_p
1837 SCM_ASSERT (scm_is_true (scm_procedure_p (proc
)),
1838 proc
, SCM_ARG1
, FUNC_NAME
);
1839 return (scm_subr_p (proc
) && SCM_SUBR_GENERIC (proc
)
1845 SCM_DEFINE (scm_enable_primitive_generic_x
, "enable-primitive-generic!", 0, 0, 1,
1848 #define FUNC_NAME s_scm_enable_primitive_generic_x
1850 SCM_VALIDATE_REST_ARGUMENT (subrs
);
1851 while (!scm_is_null (subrs
))
1853 SCM subr
= SCM_CAR (subrs
);
1854 SCM_ASSERT (scm_subr_p (subr
) && SCM_SUBR_GENERIC (subr
),
1855 subr
, SCM_ARGn
, FUNC_NAME
);
1856 *SCM_SUBR_GENERIC (subr
)
1857 = scm_make (scm_list_3 (scm_class_generic
,
1860 subrs
= SCM_CDR (subrs
);
1862 return SCM_UNSPECIFIED
;
1866 SCM_DEFINE (scm_primitive_generic_generic
, "primitive-generic-generic", 1, 0, 0,
1869 #define FUNC_NAME s_scm_primitive_generic_generic
1871 if (scm_subr_p (subr
) && SCM_SUBR_GENERIC (subr
))
1873 if (!*SCM_SUBR_GENERIC (subr
))
1874 scm_enable_primitive_generic_x (scm_list_1 (subr
));
1875 return *SCM_SUBR_GENERIC (subr
);
1877 SCM_WRONG_TYPE_ARG (SCM_ARG1
, subr
);
1881 typedef struct t_extension
{
1882 struct t_extension
*next
;
1888 /* Hint for `scm_gc_malloc ()' et al. when allocating `t_extension'
1890 static const char extension_gc_hint
[] = "GOOPS extension";
1892 static t_extension
*extensions
= 0;
1894 SCM_VARIABLE (scm_var_make_extended_generic
, "make-extended-generic");
1897 scm_c_extend_primitive_generic (SCM extended
, SCM extension
)
1902 if (!*SCM_SUBR_GENERIC (extended
))
1903 scm_enable_primitive_generic_x (scm_list_1 (extended
));
1904 gf
= *SCM_SUBR_GENERIC (extended
);
1905 gext
= scm_call_2 (SCM_VARIABLE_REF (scm_var_make_extended_generic
),
1907 SCM_SNAME (extension
));
1908 SCM_SET_SUBR_GENERIC (extension
, gext
);
1912 t_extension
*e
= scm_gc_malloc (sizeof (t_extension
),
1914 t_extension
**loc
= &extensions
;
1915 /* Make sure that extensions are placed before their own
1916 * extensions in the extensions list. O(N^2) algorithm, but
1917 * extensions of primitive generics are rare.
1919 while (*loc
&& extension
!= (*loc
)->extended
)
1920 loc
= &(*loc
)->next
;
1922 e
->extended
= extended
;
1923 e
->extension
= extension
;
1929 setup_extended_primitive_generics ()
1933 t_extension
*e
= extensions
;
1934 scm_c_extend_primitive_generic (e
->extended
, e
->extension
);
1935 extensions
= e
->next
;
1939 /******************************************************************************
1941 * Protocol for calling a generic fumction
1942 * This protocol is roughly equivalent to (parameter are a little bit different
1943 * for efficiency reasons):
1945 * + apply-generic (gf args)
1946 * + compute-applicable-methods (gf args ...)
1947 * + sort-applicable-methods (methods args)
1948 * + apply-methods (gf methods args)
1950 * apply-methods calls make-next-method to build the "continuation" of a a
1951 * method. Applying a next-method will call apply-next-method which in
1952 * turn will call apply again to call effectively the following method.
1954 ******************************************************************************/
1957 applicablep (SCM actual
, SCM formal
)
1959 /* We already know that the cpl is well formed. */
1960 return scm_is_true (scm_c_memq (formal
, SCM_SLOT (actual
, scm_si_cpl
)));
1964 more_specificp (SCM m1
, SCM m2
, SCM
const *targs
)
1966 register SCM s1
, s2
;
1970 * m1 and m2 can have != length (i.e. one can be one element longer than the
1971 * other when we have a dotted parameter list). For instance, with the call
1974 * (define-method M (a . l) ....)
1975 * (define-method M (a) ....)
1977 * we consider that the second method is more specific.
1979 * BTW, targs is an array of types. We don't need it's size since
1980 * we already know that m1 and m2 are applicable (no risk to go past
1981 * the end of this array).
1984 for (i
=0, s1
=SPEC_OF(m1
), s2
=SPEC_OF(m2
); ; i
++, s1
=SCM_CDR(s1
), s2
=SCM_CDR(s2
)) {
1985 if (scm_is_null(s1
)) return 1;
1986 if (scm_is_null(s2
)) return 0;
1987 if (SCM_CAR(s1
) != SCM_CAR(s2
)) {
1988 register SCM l
, cs1
= SCM_CAR(s1
), cs2
= SCM_CAR(s2
);
1990 for (l
= SCM_SLOT (targs
[i
], scm_si_cpl
); ; l
= SCM_CDR(l
)) {
1991 if (cs1
== SCM_CAR(l
))
1993 if (cs2
== SCM_CAR(l
))
1996 return 0;/* should not occur! */
1999 return 0; /* should not occur! */
2002 #define BUFFSIZE 32 /* big enough for most uses */
2005 scm_i_vector2list (SCM l
, long len
)
2008 SCM z
= scm_c_make_vector (len
, SCM_UNDEFINED
);
2010 for (j
= 0; j
< len
; j
++, l
= SCM_CDR (l
)) {
2011 SCM_SIMPLE_VECTOR_SET (z
, j
, SCM_CAR (l
));
2017 sort_applicable_methods (SCM method_list
, long size
, SCM
const *targs
)
2020 SCM
*v
, vector
= SCM_EOL
;
2021 SCM buffer
[BUFFSIZE
];
2022 SCM save
= method_list
;
2023 scm_t_array_handle handle
;
2025 /* For reasonably sized method_lists we can try to avoid all the
2026 * consing and reorder the list in place...
2027 * This idea is due to David McClain <Dave_McClain@msn.com>
2029 if (size
<= BUFFSIZE
)
2031 for (i
= 0; i
< size
; i
++)
2033 buffer
[i
] = SCM_CAR (method_list
);
2034 method_list
= SCM_CDR (method_list
);
2040 /* Too many elements in method_list to keep everything locally */
2041 vector
= scm_i_vector2list (save
, size
);
2042 v
= scm_vector_writable_elements (vector
, &handle
, NULL
, NULL
);
2045 /* Use a simple shell sort since it is generally faster than qsort on
2046 * small vectors (which is probably mostly the case when we have to
2047 * sort a list of applicable methods).
2049 for (incr
= size
/ 2; incr
; incr
/= 2)
2051 for (i
= incr
; i
< size
; i
++)
2053 for (j
= i
- incr
; j
>= 0; j
-= incr
)
2055 if (more_specificp (v
[j
], v
[j
+incr
], targs
))
2059 SCM tmp
= v
[j
+ incr
];
2067 if (size
<= BUFFSIZE
)
2069 /* We did it in locally, so restore the original list (reordered) in-place */
2070 for (i
= 0, method_list
= save
; i
< size
; i
++, v
++)
2072 SCM_SETCAR (method_list
, *v
);
2073 method_list
= SCM_CDR (method_list
);
2078 /* If we are here, that's that we did it the hard way... */
2079 scm_array_handle_release (&handle
);
2080 return scm_vector_to_list (vector
);
2084 scm_compute_applicable_methods (SCM gf
, SCM args
, long len
, int find_method_p
)
2088 SCM l
, fl
, applicable
= SCM_EOL
;
2090 SCM buffer
[BUFFSIZE
];
2094 scm_t_array_handle handle
;
2096 /* Build the list of arguments types */
2097 if (len
>= BUFFSIZE
)
2099 tmp
= scm_c_make_vector (len
, SCM_UNDEFINED
);
2100 types
= p
= scm_vector_writable_elements (tmp
, &handle
, NULL
, NULL
);
2103 note that we don't have to work to reset the generation
2104 count. TMP is a new vector anyway, and it is found
2111 for ( ; !scm_is_null (args
); args
= SCM_CDR (args
))
2112 *p
++ = scm_class_of (SCM_CAR (args
));
2114 /* Build a list of all applicable methods */
2115 for (l
= scm_generic_function_methods (gf
); !scm_is_null (l
); l
= SCM_CDR (l
))
2117 fl
= SPEC_OF (SCM_CAR (l
));
2118 /* Only accept accessors which match exactly in first arg. */
2119 if (SCM_ACCESSORP (SCM_CAR (l
))
2120 && (scm_is_null (fl
) || types
[0] != SCM_CAR (fl
)))
2122 for (i
= 0; ; i
++, fl
= SCM_CDR (fl
))
2124 if (SCM_INSTANCEP (fl
)
2125 /* We have a dotted argument list */
2126 || (i
>= len
&& scm_is_null (fl
)))
2127 { /* both list exhausted */
2128 applicable
= scm_cons (SCM_CAR (l
), applicable
);
2134 || !applicablep (types
[i
], SCM_CAR (fl
)))
2139 if (len
>= BUFFSIZE
)
2140 scm_array_handle_release (&handle
);
2146 CALL_GF2 ("no-applicable-method", gf
, save
);
2147 /* if we are here, it's because no-applicable-method hasn't signaled an error */
2153 : sort_applicable_methods (applicable
, count
, types
));
2157 SCM_PROC (s_sys_compute_applicable_methods
, "%compute-applicable-methods", 2, 0, 0, scm_sys_compute_applicable_methods
);
2160 static const char s_sys_compute_applicable_methods
[] = "%compute-applicable-methods";
2163 scm_sys_compute_applicable_methods (SCM gf
, SCM args
)
2164 #define FUNC_NAME s_sys_compute_applicable_methods
2167 SCM_VALIDATE_GENERIC (1, gf
);
2168 n
= scm_ilength (args
);
2169 SCM_ASSERT (n
>= 0, args
, SCM_ARG2
, FUNC_NAME
);
2170 return scm_compute_applicable_methods (gf
, args
, n
, 1);
2174 SCM_SYMBOL (sym_compute_applicable_methods
, "compute-applicable-methods");
2175 SCM_VARIABLE_INIT (var_compute_applicable_methods
, "compute-applicable-methods", scm_c_define_gsubr (s_sys_compute_applicable_methods
, 2, 0, 0, scm_sys_compute_applicable_methods
));
2178 lock_cache_mutex (void *m
)
2180 SCM mutex
= SCM_PACK ((scm_t_bits
) m
);
2181 scm_lock_mutex (mutex
);
2185 unlock_cache_mutex (void *m
)
2187 SCM mutex
= SCM_PACK ((scm_t_bits
) m
);
2188 scm_unlock_mutex (mutex
);
2192 call_memoize_method (void *a
)
2194 SCM args
= SCM_PACK ((scm_t_bits
) a
);
2195 SCM gf
= SCM_CAR (args
);
2196 SCM x
= SCM_CADR (args
);
2197 /* First check if another thread has inserted a method between
2198 * the cache miss and locking the mutex.
2200 SCM cmethod
= scm_mcache_lookup_cmethod (x
, SCM_CDDR (args
));
2201 if (scm_is_true (cmethod
))
2203 /*fixme* Use scm_apply */
2204 return CALL_GF3 ("memoize-method!", gf
, SCM_CDDR (args
), x
);
2208 scm_memoize_method (SCM x
, SCM args
)
2210 SCM gf
= SCM_CAR (scm_last_pair (x
));
2211 return scm_internal_dynamic_wind (
2213 call_memoize_method
,
2215 (void *) SCM_UNPACK (scm_cons2 (gf
, x
, args
)),
2216 (void *) SCM_UNPACK (SCM_SLOT (gf
, scm_si_cache_mutex
)));
2219 /******************************************************************************
2221 * A simple make (which will be redefined later in Scheme)
2222 * This version handles only creation of gf, methods and classes (no instances)
2224 * Since this code will disappear when Goops will be fully booted,
2225 * no precaution is taken to be efficient.
2227 ******************************************************************************/
2229 SCM_KEYWORD (k_setter
, "setter");
2230 SCM_KEYWORD (k_specializers
, "specializers");
2231 SCM_KEYWORD (k_procedure
, "procedure");
2232 SCM_KEYWORD (k_dsupers
, "dsupers");
2233 SCM_KEYWORD (k_slots
, "slots");
2234 SCM_KEYWORD (k_gf
, "generic-function");
2236 SCM_DEFINE (scm_make
, "make", 0, 0, 1,
2238 "Make a new object. @var{args} must contain the class and\n"
2239 "all necessary initialization information.")
2240 #define FUNC_NAME s_scm_make
2243 long len
= scm_ilength (args
);
2245 if (len
<= 0 || (len
& 1) == 0)
2246 SCM_WRONG_NUM_ARGS ();
2248 class = SCM_CAR(args
);
2249 args
= SCM_CDR(args
);
2251 if (class == scm_class_generic
|| class == scm_class_accessor
)
2253 z
= scm_make_struct (class, SCM_INUM0
,
2254 scm_list_5 (SCM_EOL
,
2259 scm_set_procedure_property_x (z
, scm_sym_name
,
2260 scm_get_keyword (k_name
,
2263 clear_method_cache (z
);
2264 if (class == scm_class_accessor
)
2266 SCM setter
= scm_get_keyword (k_setter
, args
, SCM_BOOL_F
);
2267 if (scm_is_true (setter
))
2268 scm_sys_set_object_setter_x (z
, setter
);
2273 z
= scm_sys_allocate_instance (class, args
);
2275 if (class == scm_class_method
2276 || class == scm_class_simple_method
2277 || class == scm_class_accessor_method
)
2279 SCM_SET_SLOT (z
, scm_si_generic_function
,
2280 scm_i_get_keyword (k_gf
,
2285 SCM_SET_SLOT (z
, scm_si_specializers
,
2286 scm_i_get_keyword (k_specializers
,
2291 SCM_SET_SLOT (z
, scm_si_procedure
,
2292 scm_i_get_keyword (k_procedure
,
2297 SCM_SET_SLOT (z
, scm_si_code_table
, SCM_EOL
);
2301 /* In all the others case, make a new class .... No instance here */
2302 SCM_SET_SLOT (z
, scm_si_name
,
2303 scm_i_get_keyword (k_name
,
2306 scm_from_locale_symbol ("???"),
2308 SCM_SET_SLOT (z
, scm_si_direct_supers
,
2309 scm_i_get_keyword (k_dsupers
,
2314 SCM_SET_SLOT (z
, scm_si_direct_slots
,
2315 scm_i_get_keyword (k_slots
,
2326 SCM_DEFINE (scm_find_method
, "find-method", 0, 0, 1,
2329 #define FUNC_NAME s_scm_find_method
2332 long len
= scm_ilength (l
);
2335 SCM_WRONG_NUM_ARGS ();
2337 gf
= SCM_CAR(l
); l
= SCM_CDR(l
);
2338 SCM_VALIDATE_GENERIC (1, gf
);
2339 if (scm_is_null (SCM_SLOT (gf
, scm_si_methods
)))
2340 SCM_MISC_ERROR ("no methods for generic ~S", scm_list_1 (gf
));
2342 return scm_compute_applicable_methods (gf
, l
, len
- 1, 1);
2346 SCM_DEFINE (scm_sys_method_more_specific_p
, "%method-more-specific?", 3, 0, 0,
2347 (SCM m1
, SCM m2
, SCM targs
),
2348 "Return true if method @var{m1} is more specific than @var{m2} "
2349 "given the argument types (classes) listed in @var{targs}.")
2350 #define FUNC_NAME s_scm_sys_method_more_specific_p
2354 long i
, len
, m1_specs
, m2_specs
;
2355 scm_t_array_handle handle
;
2357 SCM_VALIDATE_METHOD (1, m1
);
2358 SCM_VALIDATE_METHOD (2, m2
);
2360 len
= scm_ilength (targs
);
2361 m1_specs
= scm_ilength (SPEC_OF (m1
));
2362 m2_specs
= scm_ilength (SPEC_OF (m2
));
2363 SCM_ASSERT ((len
>= m1_specs
) || (len
>= m2_specs
),
2364 targs
, SCM_ARG3
, FUNC_NAME
);
2366 /* Verify that all the arguments of TARGS are classes and place them
2369 v
= scm_c_make_vector (len
, SCM_EOL
);
2370 v_elts
= scm_vector_writable_elements (v
, &handle
, NULL
, NULL
);
2372 for (i
= 0, l
= targs
;
2373 i
< len
&& scm_is_pair (l
);
2374 i
++, l
= SCM_CDR (l
))
2376 SCM_ASSERT (SCM_CLASSP (SCM_CAR (l
)), targs
, SCM_ARG3
, FUNC_NAME
);
2377 v_elts
[i
] = SCM_CAR (l
);
2379 result
= more_specificp (m1
, m2
, v_elts
) ? SCM_BOOL_T
: SCM_BOOL_F
;
2381 scm_array_handle_release (&handle
);
2389 /******************************************************************************
2393 ******************************************************************************/
2396 fix_cpl (SCM c
, SCM before
, SCM after
)
2398 SCM cpl
= SCM_SLOT (c
, scm_si_cpl
);
2399 SCM ls
= scm_c_memq (after
, cpl
);
2400 SCM tail
= scm_delq1_x (before
, SCM_CDR (ls
));
2401 if (scm_is_false (ls
))
2402 /* if this condition occurs, fix_cpl should not be applied this way */
2404 SCM_SETCAR (ls
, before
);
2405 SCM_SETCDR (ls
, scm_cons (after
, tail
));
2407 SCM dslots
= SCM_SLOT (c
, scm_si_direct_slots
);
2408 SCM slots
= build_slots_list (maplist (dslots
), cpl
);
2409 SCM g_n_s
= compute_getters_n_setters (slots
);
2410 SCM_SET_SLOT (c
, scm_si_slots
, slots
);
2411 SCM_SET_SLOT (c
, scm_si_getters_n_setters
, g_n_s
);
2417 make_stdcls (SCM
*var
, char *name
, SCM meta
, SCM super
, SCM slots
)
2419 SCM tmp
= scm_from_locale_symbol (name
);
2421 *var
= scm_permanent_object (scm_basic_make_class (meta
,
2425 : scm_list_1 (super
),
2431 SCM_KEYWORD (k_slot_definition
, "slot-definition");
2434 create_standard_classes (void)
2437 SCM method_slots
= scm_list_4 (scm_from_locale_symbol ("generic-function"),
2438 scm_from_locale_symbol ("specializers"),
2440 scm_from_locale_symbol ("code-table"));
2441 SCM amethod_slots
= scm_list_1 (scm_list_3 (scm_from_locale_symbol ("slot-definition"),
2443 k_slot_definition
));
2444 SCM mutex_slot
= scm_list_1 (scm_from_locale_symbol ("make-mutex"));
2445 SCM mutex_closure
= scm_i_eval_x (scm_list_3 (scm_sym_lambda
,
2449 SCM gf_slots
= scm_list_5 (scm_from_locale_symbol ("methods"),
2450 scm_list_3 (scm_from_locale_symbol ("n-specialized"),
2453 scm_list_3 (scm_from_locale_symbol ("used-by"),
2456 scm_list_3 (scm_from_locale_symbol ("cache-mutex"),
2459 scm_list_3 (scm_from_locale_symbol ("extended-by"),
2462 SCM egf_slots
= scm_list_1 (scm_list_3 (scm_from_locale_symbol ("extends"),
2465 /* Foreign class slot classes */
2466 make_stdcls (&scm_class_foreign_slot
, "<foreign-slot>",
2467 scm_class_class
, scm_class_top
, SCM_EOL
);
2468 make_stdcls (&scm_class_protected
, "<protected-slot>",
2469 scm_class_class
, scm_class_foreign_slot
, SCM_EOL
);
2470 make_stdcls (&scm_class_opaque
, "<opaque-slot>",
2471 scm_class_class
, scm_class_foreign_slot
, SCM_EOL
);
2472 make_stdcls (&scm_class_read_only
, "<read-only-slot>",
2473 scm_class_class
, scm_class_foreign_slot
, SCM_EOL
);
2474 make_stdcls (&scm_class_self
, "<self-slot>",
2476 scm_class_read_only
,
2478 make_stdcls (&scm_class_protected_opaque
, "<protected-opaque-slot>",
2480 scm_list_2 (scm_class_protected
, scm_class_opaque
),
2482 make_stdcls (&scm_class_protected_read_only
, "<protected-read-only-slot>",
2484 scm_list_2 (scm_class_protected
, scm_class_read_only
),
2486 make_stdcls (&scm_class_scm
, "<scm-slot>",
2487 scm_class_class
, scm_class_protected
, SCM_EOL
);
2488 make_stdcls (&scm_class_int
, "<int-slot>",
2489 scm_class_class
, scm_class_foreign_slot
, SCM_EOL
);
2490 make_stdcls (&scm_class_float
, "<float-slot>",
2491 scm_class_class
, scm_class_foreign_slot
, SCM_EOL
);
2492 make_stdcls (&scm_class_double
, "<double-slot>",
2493 scm_class_class
, scm_class_foreign_slot
, SCM_EOL
);
2495 /* Continue initialization of class <class> */
2497 slots
= build_class_class_slots ();
2498 SCM_SET_SLOT (scm_class_class
, scm_si_direct_slots
, slots
);
2499 SCM_SET_SLOT (scm_class_class
, scm_si_slots
, slots
);
2500 SCM_SET_SLOT (scm_class_class
, scm_si_getters_n_setters
,
2501 compute_getters_n_setters (slots
));
2503 make_stdcls (&scm_class_foreign_class
, "<foreign-class>",
2504 scm_class_class
, scm_class_class
,
2505 scm_list_2 (scm_list_3 (scm_from_locale_symbol ("constructor"),
2508 scm_list_3 (scm_from_locale_symbol ("destructor"),
2510 scm_class_opaque
)));
2511 make_stdcls (&scm_class_foreign_object
, "<foreign-object>",
2512 scm_class_foreign_class
, scm_class_object
, SCM_EOL
);
2513 SCM_SET_CLASS_FLAGS (scm_class_foreign_object
, SCM_CLASSF_FOREIGN
);
2515 /* scm_class_generic functions classes */
2516 make_stdcls (&scm_class_procedure_class
, "<procedure-class>",
2517 scm_class_class
, scm_class_class
, SCM_EOL
);
2518 make_stdcls (&scm_class_entity_class
, "<entity-class>",
2519 scm_class_class
, scm_class_procedure_class
, SCM_EOL
);
2520 make_stdcls (&scm_class_operator_class
, "<operator-class>",
2521 scm_class_class
, scm_class_procedure_class
, SCM_EOL
);
2522 make_stdcls (&scm_class_operator_with_setter_class
,
2523 "<operator-with-setter-class>",
2524 scm_class_class
, scm_class_operator_class
, SCM_EOL
);
2525 make_stdcls (&scm_class_method
, "<method>",
2526 scm_class_class
, scm_class_object
, method_slots
);
2527 make_stdcls (&scm_class_simple_method
, "<simple-method>",
2528 scm_class_class
, scm_class_method
, SCM_EOL
);
2529 SCM_SET_CLASS_FLAGS (scm_class_simple_method
, SCM_CLASSF_SIMPLE_METHOD
);
2530 make_stdcls (&scm_class_accessor_method
, "<accessor-method>",
2531 scm_class_class
, scm_class_simple_method
, amethod_slots
);
2532 SCM_SET_CLASS_FLAGS (scm_class_accessor_method
, SCM_CLASSF_ACCESSOR_METHOD
);
2533 make_stdcls (&scm_class_applicable
, "<applicable>",
2534 scm_class_class
, scm_class_top
, SCM_EOL
);
2535 make_stdcls (&scm_class_entity
, "<entity>",
2536 scm_class_entity_class
,
2537 scm_list_2 (scm_class_object
, scm_class_applicable
),
2539 make_stdcls (&scm_class_entity_with_setter
, "<entity-with-setter>",
2540 scm_class_entity_class
, scm_class_entity
, SCM_EOL
);
2541 make_stdcls (&scm_class_generic
, "<generic>",
2542 scm_class_entity_class
, scm_class_entity
, gf_slots
);
2543 SCM_SET_CLASS_FLAGS (scm_class_generic
, SCM_CLASSF_PURE_GENERIC
);
2544 make_stdcls (&scm_class_extended_generic
, "<extended-generic>",
2545 scm_class_entity_class
, scm_class_generic
, egf_slots
);
2546 SCM_SET_CLASS_FLAGS (scm_class_extended_generic
, SCM_CLASSF_PURE_GENERIC
);
2547 make_stdcls (&scm_class_generic_with_setter
, "<generic-with-setter>",
2548 scm_class_entity_class
,
2549 scm_list_2 (scm_class_generic
, scm_class_entity_with_setter
),
2551 SCM_SET_CLASS_FLAGS (scm_class_generic_with_setter
, SCM_CLASSF_PURE_GENERIC
);
2552 make_stdcls (&scm_class_accessor
, "<accessor>",
2553 scm_class_entity_class
, scm_class_generic_with_setter
, SCM_EOL
);
2554 SCM_SET_CLASS_FLAGS (scm_class_accessor
, SCM_CLASSF_PURE_GENERIC
);
2555 make_stdcls (&scm_class_extended_generic_with_setter
,
2556 "<extended-generic-with-setter>",
2557 scm_class_entity_class
,
2558 scm_list_2 (scm_class_generic_with_setter
,
2559 scm_class_extended_generic
),
2561 SCM_SET_CLASS_FLAGS (scm_class_extended_generic_with_setter
,
2562 SCM_CLASSF_PURE_GENERIC
);
2563 make_stdcls (&scm_class_extended_accessor
, "<extended-accessor>",
2564 scm_class_entity_class
,
2565 scm_list_2 (scm_class_accessor
,
2566 scm_class_extended_generic_with_setter
),
2568 fix_cpl (scm_class_extended_accessor
,
2569 scm_class_extended_generic
, scm_class_generic
);
2570 SCM_SET_CLASS_FLAGS (scm_class_extended_accessor
, SCM_CLASSF_PURE_GENERIC
);
2572 /* Primitive types classes */
2573 make_stdcls (&scm_class_boolean
, "<boolean>",
2574 scm_class_class
, scm_class_top
, SCM_EOL
);
2575 make_stdcls (&scm_class_char
, "<char>",
2576 scm_class_class
, scm_class_top
, SCM_EOL
);
2577 make_stdcls (&scm_class_list
, "<list>",
2578 scm_class_class
, scm_class_top
, SCM_EOL
);
2579 make_stdcls (&scm_class_pair
, "<pair>",
2580 scm_class_class
, scm_class_list
, SCM_EOL
);
2581 make_stdcls (&scm_class_null
, "<null>",
2582 scm_class_class
, scm_class_list
, SCM_EOL
);
2583 make_stdcls (&scm_class_string
, "<string>",
2584 scm_class_class
, scm_class_top
, SCM_EOL
);
2585 make_stdcls (&scm_class_symbol
, "<symbol>",
2586 scm_class_class
, scm_class_top
, SCM_EOL
);
2587 make_stdcls (&scm_class_vector
, "<vector>",
2588 scm_class_class
, scm_class_top
, SCM_EOL
);
2589 make_stdcls (&scm_class_number
, "<number>",
2590 scm_class_class
, scm_class_top
, SCM_EOL
);
2591 make_stdcls (&scm_class_complex
, "<complex>",
2592 scm_class_class
, scm_class_number
, SCM_EOL
);
2593 make_stdcls (&scm_class_real
, "<real>",
2594 scm_class_class
, scm_class_complex
, SCM_EOL
);
2595 make_stdcls (&scm_class_integer
, "<integer>",
2596 scm_class_class
, scm_class_real
, SCM_EOL
);
2597 make_stdcls (&scm_class_fraction
, "<fraction>",
2598 scm_class_class
, scm_class_real
, SCM_EOL
);
2599 make_stdcls (&scm_class_keyword
, "<keyword>",
2600 scm_class_class
, scm_class_top
, SCM_EOL
);
2601 make_stdcls (&scm_class_unknown
, "<unknown>",
2602 scm_class_class
, scm_class_top
, SCM_EOL
);
2603 make_stdcls (&scm_class_procedure
, "<procedure>",
2604 scm_class_procedure_class
, scm_class_applicable
, SCM_EOL
);
2605 make_stdcls (&scm_class_procedure_with_setter
, "<procedure-with-setter>",
2606 scm_class_procedure_class
, scm_class_procedure
, SCM_EOL
);
2607 make_stdcls (&scm_class_primitive_generic
, "<primitive-generic>",
2608 scm_class_procedure_class
, scm_class_procedure
, SCM_EOL
);
2609 make_stdcls (&scm_class_port
, "<port>",
2610 scm_class_class
, scm_class_top
, SCM_EOL
);
2611 make_stdcls (&scm_class_input_port
, "<input-port>",
2612 scm_class_class
, scm_class_port
, SCM_EOL
);
2613 make_stdcls (&scm_class_output_port
, "<output-port>",
2614 scm_class_class
, scm_class_port
, SCM_EOL
);
2615 make_stdcls (&scm_class_input_output_port
, "<input-output-port>",
2617 scm_list_2 (scm_class_input_port
, scm_class_output_port
),
2621 /**********************************************************************
2625 **********************************************************************/
2628 make_class_from_template (char const *template, char const *type_name
, SCM supers
, int applicablep
)
2634 sprintf (buffer
, template, type_name
);
2635 name
= scm_from_locale_symbol (buffer
);
2638 name
= SCM_GOOPS_UNBOUND
;
2640 class = scm_permanent_object (scm_basic_make_class (applicablep
2641 ? scm_class_procedure_class
2647 /* Only define name if doesn't already exist. */
2648 if (!SCM_GOOPS_UNBOUNDP (name
)
2649 && scm_is_false (scm_call_2 (scm_goops_lookup_closure
, name
, SCM_BOOL_F
)))
2650 DEFVAR (name
, class);
2655 scm_make_extended_class (char const *type_name
, int applicablep
)
2657 return make_class_from_template ("<%s>",
2659 scm_list_1 (applicablep
2660 ? scm_class_applicable
2666 scm_i_inherit_applicable (SCM c
)
2668 if (!SCM_SUBCLASSP (c
, scm_class_applicable
))
2670 SCM dsupers
= SCM_SLOT (c
, scm_si_direct_supers
);
2671 SCM cpl
= SCM_SLOT (c
, scm_si_cpl
);
2672 /* patch scm_class_applicable into direct-supers */
2673 SCM top
= scm_c_memq (scm_class_top
, dsupers
);
2674 if (scm_is_false (top
))
2675 dsupers
= scm_append (scm_list_2 (dsupers
,
2676 scm_list_1 (scm_class_applicable
)));
2679 SCM_SETCAR (top
, scm_class_applicable
);
2680 SCM_SETCDR (top
, scm_cons (scm_class_top
, SCM_CDR (top
)));
2682 SCM_SET_SLOT (c
, scm_si_direct_supers
, dsupers
);
2683 /* patch scm_class_applicable into cpl */
2684 top
= scm_c_memq (scm_class_top
, cpl
);
2685 if (scm_is_false (top
))
2689 SCM_SETCAR (top
, scm_class_applicable
);
2690 SCM_SETCDR (top
, scm_cons (scm_class_top
, SCM_CDR (top
)));
2692 /* add class to direct-subclasses of scm_class_applicable */
2693 SCM_SET_SLOT (scm_class_applicable
,
2694 scm_si_direct_subclasses
,
2695 scm_cons (c
, SCM_SLOT (scm_class_applicable
,
2696 scm_si_direct_subclasses
)));
2701 create_smob_classes (void)
2705 for (i
= 0; i
< SCM_I_MAX_SMOB_TYPE_COUNT
; ++i
)
2706 scm_smob_class
[i
] = 0;
2708 scm_smob_class
[SCM_TC2SMOBNUM (scm_tc16_keyword
)] = scm_class_keyword
;
2710 for (i
= 0; i
< scm_numsmob
; ++i
)
2711 if (!scm_smob_class
[i
])
2712 scm_smob_class
[i
] = scm_make_extended_class (SCM_SMOBNAME (i
),
2713 scm_smobs
[i
].apply
!= 0);
2717 scm_make_port_classes (long ptobnum
, char *type_name
)
2719 SCM c
, class = make_class_from_template ("<%s-port>",
2721 scm_list_1 (scm_class_port
),
2723 scm_port_class
[SCM_IN_PCLASS_INDEX
+ ptobnum
]
2724 = make_class_from_template ("<%s-input-port>",
2726 scm_list_2 (class, scm_class_input_port
),
2728 scm_port_class
[SCM_OUT_PCLASS_INDEX
+ ptobnum
]
2729 = make_class_from_template ("<%s-output-port>",
2731 scm_list_2 (class, scm_class_output_port
),
2733 scm_port_class
[SCM_INOUT_PCLASS_INDEX
+ ptobnum
]
2735 = make_class_from_template ("<%s-input-output-port>",
2737 scm_list_2 (class, scm_class_input_output_port
),
2739 /* Patch cpl (since this tree is too complex for the C level compute-cpl) */
2740 SCM_SET_SLOT (c
, scm_si_cpl
,
2741 scm_cons2 (c
, class, SCM_SLOT (scm_class_input_output_port
, scm_si_cpl
)));
2745 create_port_classes (void)
2749 for (i
= 0; i
< scm_numptob
; ++i
)
2750 scm_make_port_classes (i
, SCM_PTOBNAME (i
));
2754 make_struct_class (void *closure SCM_UNUSED
,
2755 SCM vtable
, SCM data
, SCM prev SCM_UNUSED
)
2757 if (scm_is_true (SCM_STRUCT_TABLE_NAME (data
)))
2758 SCM_SET_STRUCT_TABLE_CLASS (data
,
2759 scm_make_extended_class
2760 (scm_i_symbol_chars (SCM_STRUCT_TABLE_NAME (data
)),
2761 SCM_CLASS_FLAGS (vtable
) & SCM_CLASSF_OPERATOR
));
2762 return SCM_UNSPECIFIED
;
2766 create_struct_classes (void)
2768 scm_internal_hash_fold (make_struct_class
, 0, SCM_BOOL_F
, scm_struct_table
);
2771 /**********************************************************************
2775 **********************************************************************/
2780 if (!goops_loaded_p
)
2781 scm_c_resolve_module ("oop goops");
2786 scm_make_foreign_object (SCM
class, SCM initargs
)
2787 #define FUNC_NAME s_scm_make
2789 void * (*constructor
) (SCM
)
2790 = (void * (*) (SCM
)) SCM_SLOT (class, scm_si_constructor
);
2791 if (constructor
== 0)
2792 SCM_MISC_ERROR ("Can't make instances of class ~S", scm_list_1 (class));
2793 return scm_wrap_object (class, constructor (initargs
));
2799 scm_free_foreign_object (SCM
*class, SCM
*data
)
2801 size_t (*destructor
) (void *)
2802 = (size_t (*) (void *)) class[scm_si_destructor
];
2803 return destructor (data
);
2807 scm_make_class (SCM meta
, char *s_name
, SCM supers
, size_t size
,
2808 void * (*constructor
) (SCM initargs
),
2809 size_t (*destructor
) (void *))
2812 name
= scm_from_locale_symbol (s_name
);
2813 if (scm_is_null (supers
))
2814 supers
= scm_list_1 (scm_class_foreign_object
);
2815 class = scm_basic_basic_make_class (meta
, name
, supers
, SCM_EOL
);
2816 scm_sys_inherit_magic_x (class, supers
);
2818 if (destructor
!= 0)
2820 SCM_SET_SLOT (class, scm_si_destructor
, (SCM
) destructor
);
2821 SCM_SET_CLASS_DESTRUCTOR (class, scm_free_foreign_object
);
2825 SCM_SET_CLASS_INSTANCE_SIZE (class, size
);
2828 SCM_SET_SLOT (class, scm_si_layout
, scm_from_locale_symbol (""));
2829 SCM_SET_SLOT (class, scm_si_constructor
, (SCM
) constructor
);
2834 SCM_SYMBOL (sym_o
, "o");
2835 SCM_SYMBOL (sym_x
, "x");
2837 SCM_KEYWORD (k_accessor
, "accessor");
2838 SCM_KEYWORD (k_getter
, "getter");
2841 default_setter (SCM obj SCM_UNUSED
, SCM c SCM_UNUSED
)
2843 scm_misc_error ("slot-set!", "read-only slot", SCM_EOL
);
2848 scm_add_slot (SCM
class, char *slot_name
, SCM slot_class
,
2849 SCM (*getter
) (SCM obj
),
2850 SCM (*setter
) (SCM obj
, SCM x
),
2851 char *accessor_name
)
2854 SCM get
= scm_c_make_subr ("goops:get", scm_tc7_subr_1
, getter
);
2855 SCM set
= scm_c_make_subr ("goops:set", scm_tc7_subr_2
,
2856 setter
? setter
: default_setter
);
2858 /* Dirk:FIXME:: The following two expressions make use of the fact that
2859 * the memoizer will accept a subr-object in the place of a function.
2860 * This is not guaranteed to stay this way. */
2861 SCM getm
= scm_i_eval_x (scm_list_3 (scm_sym_lambda
,
2863 scm_list_2 (get
, sym_o
)),
2865 SCM setm
= scm_i_eval_x (scm_list_3 (scm_sym_lambda
,
2866 scm_list_2 (sym_o
, sym_x
),
2867 scm_list_3 (set
, sym_o
, sym_x
)),
2871 SCM name
= scm_from_locale_symbol (slot_name
);
2872 SCM aname
= scm_from_locale_symbol (accessor_name
);
2873 SCM gf
= scm_ensure_accessor (aname
);
2874 SCM slot
= scm_list_5 (name
,
2877 setter
? k_accessor
: k_getter
,
2879 scm_add_method (gf
, scm_make (scm_list_5 (scm_class_accessor_method
,
2884 scm_add_method (scm_setter (gf
),
2885 scm_make (scm_list_5 (scm_class_accessor_method
,
2887 scm_list_2 (class, scm_class_top
),
2892 SCM_SET_SLOT (class, scm_si_slots
,
2893 scm_append_x (scm_list_2 (SCM_SLOT (class, scm_si_slots
),
2894 scm_list_1 (slot
))));
2896 SCM n
= SCM_SLOT (class, scm_si_nfields
);
2897 SCM gns
= scm_list_n (name
, SCM_BOOL_F
, get
, set
, n
, scm_from_int (1),
2899 SCM_SET_SLOT (class, scm_si_getters_n_setters
,
2900 scm_append_x (scm_list_2 (SCM_SLOT (class, scm_si_getters_n_setters
),
2901 scm_list_1 (gns
))));
2902 SCM_SET_SLOT (class, scm_si_nfields
, scm_sum (n
, scm_from_int (1)));
2909 scm_wrap_object (SCM
class, void *data
)
2911 return scm_double_cell (SCM_UNPACK (SCM_CDR (class)) | scm_tc3_struct
,
2919 scm_wrap_component (SCM
class, SCM container
, void *data
)
2921 SCM obj
= scm_wrap_object (class, data
);
2922 SCM handle
= scm_hash_fn_create_handle_x (scm_components
,
2928 SCM_SETCDR (handle
, container
);
2933 scm_ensure_accessor (SCM name
)
2935 SCM gf
= scm_call_2 (SCM_TOP_LEVEL_LOOKUP_CLOSURE
, name
, SCM_BOOL_F
);
2936 if (!SCM_IS_A_P (gf
, scm_class_accessor
))
2938 gf
= scm_make (scm_list_3 (scm_class_generic
, k_name
, name
));
2939 gf
= scm_make (scm_list_5 (scm_class_accessor
,
2940 k_name
, name
, k_setter
, gf
));
2945 SCM_SYMBOL (sym_internal_add_method_x
, "internal-add-method!");
2948 scm_add_method (SCM gf
, SCM m
)
2950 scm_eval (scm_list_3 (sym_internal_add_method_x
, gf
, m
), scm_module_goops
);
2955 * Debugging utilities
2958 SCM_DEFINE (scm_pure_generic_p
, "pure-generic?", 1, 0, 0,
2960 "Return @code{#t} if @var{obj} is a pure generic.")
2961 #define FUNC_NAME s_scm_pure_generic_p
2963 return scm_from_bool (SCM_PUREGENERICP (obj
));
2967 #endif /* GUILE_DEBUG */
2973 SCM_DEFINE (scm_sys_goops_loaded
, "%goops-loaded", 0, 0, 0,
2975 "Announce that GOOPS is loaded and perform initialization\n"
2976 "on the C level which depends on the loaded GOOPS modules.")
2977 #define FUNC_NAME s_scm_sys_goops_loaded
2980 var_compute_applicable_methods
=
2981 scm_sym2var (sym_compute_applicable_methods
, scm_goops_lookup_closure
,
2983 setup_extended_primitive_generics ();
2984 return SCM_UNSPECIFIED
;
2988 SCM scm_module_goops
;
2991 scm_init_goops_builtins (void)
2993 scm_module_goops
= scm_current_module ();
2994 scm_goops_lookup_closure
= scm_module_lookup_closure (scm_module_goops
);
2996 /* Not really necessary right now, but who knows...
2998 scm_permanent_object (scm_module_goops
);
2999 scm_permanent_object (scm_goops_lookup_closure
);
3001 scm_components
= scm_permanent_object (scm_make_weak_key_hash_table
3002 (scm_from_int (37)));
3004 goops_rstate
= scm_c_make_rstate ("GOOPS", 5);
3006 #include "libguile/goops.x"
3008 list_of_no_method
= scm_permanent_object (scm_list_1 (sym_no_method
));
3010 hell
= scm_calloc (hell_size
* sizeof (*hell
));
3011 hell_mutex
= scm_permanent_object (scm_make_mutex ());
3013 create_basic_classes ();
3014 create_standard_classes ();
3015 create_smob_classes ();
3016 create_struct_classes ();
3017 create_port_classes ();
3020 SCM name
= scm_from_locale_symbol ("no-applicable-method");
3021 scm_no_applicable_method
3022 = scm_permanent_object (scm_make (scm_list_3 (scm_class_generic
,
3025 DEFVAR (name
, scm_no_applicable_method
);
3028 return SCM_UNSPECIFIED
;
3034 scm_c_define_gsubr ("%init-goops-builtins", 0, 0, 0,
3035 scm_init_goops_builtins
);