1 /* Copyright (C) 1998,1999,2000,2001,2002,2003,2004
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., 59 Temple Place, Suite 330, Boston, MA 02111-1307 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>.
29 #include "libguile/_scm.h"
30 #include "libguile/alist.h"
31 #include "libguile/async.h"
32 #include "libguile/chars.h"
33 #include "libguile/debug.h"
34 #include "libguile/dynl.h"
35 #include "libguile/dynwind.h"
36 #include "libguile/eval.h"
37 #include "libguile/hashtab.h"
38 #include "libguile/keywords.h"
39 #include "libguile/macros.h"
40 #include "libguile/modules.h"
41 #include "libguile/objects.h"
42 #include "libguile/ports.h"
43 #include "libguile/procprop.h"
44 #include "libguile/random.h"
45 #include "libguile/root.h"
46 #include "libguile/smob.h"
47 #include "libguile/strings.h"
48 #include "libguile/strports.h"
49 #include "libguile/vectors.h"
50 #include "libguile/weaks.h"
52 #include "libguile/validate.h"
53 #include "libguile/goops.h"
55 #define SPEC_OF(x) SCM_SLOT (x, scm_si_specializers)
57 #define DEFVAR(v, val) \
58 { scm_eval (scm_list_3 (scm_sym_define_public, (v), (val)), \
60 /* Temporary hack until we get the new module system */
61 /*fixme* Should optimize by keeping track of the variable object itself */
62 #define GETVAR(v) (SCM_VARIABLE_REF (scm_call_2 (scm_goops_lookup_closure, \
65 /* Fixme: Should use already interned symbols */
67 #define CALL_GF1(name, a) (scm_call_1 (GETVAR (scm_from_locale_symbol (name)), \
69 #define CALL_GF2(name, a, b) (scm_call_2 (GETVAR (scm_from_locale_symbol (name)), \
71 #define CALL_GF3(name, a, b, c) (scm_call_3 (GETVAR (scm_from_locale_symbol (name)), \
73 #define CALL_GF4(name, a, b, c, d) (scm_call_4 (GETVAR (scm_from_locale_symbol (name)), \
76 /* Class redefinition protocol:
78 A class is represented by a heap header h1 which points to a
79 malloc:ed memory block m1.
81 When a new version of a class is created, a new header h2 and
82 memory block m2 are allocated. The headers h1 and h2 then switch
83 pointers so that h1 refers to m2 and h2 to m1. In this way, names
84 bound to h1 will point to the new class at the same time as h2 will
85 be a handle which the GC will use to free m1.
87 The `redefined' slot of m1 will be set to point to h1. An old
88 instance will have its class pointer (the CAR of the heap header)
89 pointing to m1. The non-immediate `redefined'-slot in m1 indicates
90 the class modification and the new class pointer can be found via
94 /* The following definition is located in libguile/objects.h:
95 #define SCM_OBJ_CLASS_REDEF(x) (SCM_STRUCT_VTABLE_DATA(x)[scm_si_redefined])
98 #define TEST_CHANGE_CLASS(obj, class) \
100 class = SCM_CLASS_OF (obj); \
101 if (scm_is_true (SCM_OBJ_CLASS_REDEF (obj))) \
103 scm_change_object_class (obj, class, SCM_OBJ_CLASS_REDEF (obj));\
104 class = SCM_CLASS_OF (obj); \
108 #define NXT_MTHD_METHODS(m) (SCM_VELTS (m)[1])
109 #define NXT_MTHD_ARGS(m) (SCM_VELTS (m)[2])
111 #define SCM_GOOPS_UNBOUND SCM_UNBOUND
112 #define SCM_GOOPS_UNBOUNDP(x) ((x) == SCM_GOOPS_UNBOUND)
114 static int goops_loaded_p
= 0;
115 static scm_t_rstate
*goops_rstate
;
117 static SCM scm_goops_lookup_closure
;
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_procedure_with_setter
, 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_entity
, scm_class_entity_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_simple_method
, scm_class_accessor_method
;
135 SCM scm_class_procedure_class
;
136 SCM scm_class_operator_class
, scm_class_operator_with_setter_class
;
137 SCM scm_class_entity_class
;
138 SCM scm_class_number
, scm_class_list
;
139 SCM scm_class_keyword
;
140 SCM scm_class_port
, scm_class_input_output_port
;
141 SCM scm_class_input_port
, scm_class_output_port
;
142 SCM scm_class_foreign_class
, scm_class_foreign_object
;
143 SCM scm_class_foreign_slot
;
144 SCM scm_class_self
, scm_class_protected
;
145 SCM scm_class_opaque
, scm_class_read_only
;
146 SCM scm_class_protected_opaque
, scm_class_protected_read_only
;
148 SCM scm_class_int
, scm_class_float
, scm_class_double
;
150 SCM
*scm_port_class
= 0;
151 SCM
*scm_smob_class
= 0;
153 SCM scm_no_applicable_method
;
155 SCM_SYMBOL (scm_sym_define_public
, "define-public");
157 static SCM
scm_make_unbound (void);
158 static SCM
scm_unbound_p (SCM obj
);
159 static SCM
scm_assert_bound (SCM value
, SCM obj
);
160 static SCM
scm_at_assert_bound_ref (SCM obj
, SCM index
);
161 static SCM
scm_sys_goops_loaded (void);
163 /* This function is used for efficient type dispatch. */
164 SCM_DEFINE (scm_class_of
, "class-of", 1, 0, 0,
166 "Return the class of @var{x}.")
167 #define FUNC_NAME s_scm_class_of
169 switch (SCM_ITAG3 (x
))
173 return scm_class_integer
;
177 return scm_class_char
;
178 else if (scm_is_bool (x
))
179 return scm_class_boolean
;
180 else if (scm_is_null (x
))
181 return scm_class_null
;
183 return scm_class_unknown
;
186 switch (SCM_TYP7 (x
))
188 case scm_tcs_cons_nimcar
:
189 return scm_class_pair
;
190 case scm_tcs_closures
:
191 return scm_class_procedure
;
193 return scm_class_symbol
;
196 return scm_class_vector
;
198 return scm_class_string
;
200 switch SCM_TYP16 (x
) {
202 return scm_class_integer
;
204 return scm_class_real
;
205 case scm_tc16_complex
:
206 return scm_class_complex
;
207 case scm_tc16_fraction
:
208 return scm_class_fraction
;
218 case scm_tc7_subr_1o
:
219 case scm_tc7_subr_2o
:
220 case scm_tc7_lsubr_2
:
222 if (SCM_SUBR_GENERIC (x
) && *SCM_SUBR_GENERIC (x
))
223 return scm_class_primitive_generic
;
225 return scm_class_procedure
;
227 return scm_class_procedure
;
229 return scm_class_procedure_with_setter
;
233 scm_t_bits type
= SCM_TYP16 (x
);
234 if (type
!= scm_tc16_port_with_ps
)
235 return scm_smob_class
[SCM_TC2SMOBNUM (type
)];
236 x
= SCM_PORT_WITH_PS_PORT (x
);
237 /* fall through to ports */
240 return scm_port_class
[(SCM_WRTNG
& SCM_CELL_WORD_0 (x
)
241 ? (SCM_RDNG
& SCM_CELL_WORD_0 (x
)
242 ? SCM_INOUT_PCLASS_INDEX
| SCM_PTOBNUM (x
)
243 : SCM_OUT_PCLASS_INDEX
| SCM_PTOBNUM (x
))
244 : SCM_IN_PCLASS_INDEX
| SCM_PTOBNUM (x
))];
246 if (SCM_OBJ_CLASS_FLAGS (x
) & SCM_CLASSF_GOOPS_VALID
)
247 return SCM_CLASS_OF (x
);
248 else if (SCM_OBJ_CLASS_FLAGS (x
) & SCM_CLASSF_GOOPS
)
251 if (! scm_is_false (SCM_OBJ_CLASS_REDEF (x
)))
252 scm_change_object_class (x
,
253 SCM_CLASS_OF (x
), /* old */
254 SCM_OBJ_CLASS_REDEF (x
)); /* new */
255 return SCM_CLASS_OF (x
);
259 /* ordinary struct */
260 SCM handle
= scm_struct_create_handle (SCM_STRUCT_VTABLE (x
));
261 if (scm_is_true (SCM_STRUCT_TABLE_CLASS (SCM_CDR (handle
))))
262 return SCM_STRUCT_TABLE_CLASS (SCM_CDR (handle
));
265 SCM name
= SCM_STRUCT_TABLE_NAME (SCM_CDR (handle
));
266 SCM
class = scm_make_extended_class (scm_is_true (name
)
267 ? scm_i_symbol_chars (name
)
269 SCM_I_OPERATORP (x
));
270 SCM_SET_STRUCT_TABLE_CLASS (SCM_CDR (handle
), class);
276 return scm_class_pair
;
278 return scm_class_unknown
;
284 case scm_tc3_closure
:
288 return scm_class_unknown
;
292 /******************************************************************************
296 * This version doesn't fully handle multiple-inheritance. It serves
297 * only for booting classes and will be overloaded in Scheme
299 ******************************************************************************/
302 map (SCM (*proc
) (SCM
), SCM ls
)
304 if (scm_is_null (ls
))
308 SCM res
= scm_cons (proc (SCM_CAR (ls
)), SCM_EOL
);
311 while (!scm_is_null (ls
))
313 SCM_SETCDR (h
, scm_cons (proc (SCM_CAR (ls
)), SCM_EOL
));
325 while (!scm_is_null (ls
))
327 SCM el
= SCM_CAR (ls
);
328 if (scm_is_false (scm_c_memq (el
, res
)))
329 res
= scm_cons (el
, res
);
336 compute_cpl (SCM
class)
339 return CALL_GF1 ("compute-cpl", class);
342 SCM supers
= SCM_SLOT (class, scm_si_direct_supers
);
343 SCM ls
= scm_append (scm_acons (class, supers
,
344 map (compute_cpl
, supers
)));
345 return scm_reverse_x (filter_cpl (ls
), SCM_EOL
);
349 /******************************************************************************
353 ******************************************************************************/
356 remove_duplicate_slots (SCM l
, SCM res
, SCM slots_already_seen
)
364 if (!scm_is_symbol (tmp
))
365 scm_misc_error ("%compute-slots", "bad slot name ~S", scm_list_1 (tmp
));
367 if (scm_is_false (scm_c_memq (tmp
, slots_already_seen
))) {
368 res
= scm_cons (SCM_CAR (l
), res
);
369 slots_already_seen
= scm_cons (tmp
, slots_already_seen
);
372 return remove_duplicate_slots (SCM_CDR (l
), res
, slots_already_seen
);
376 build_slots_list (SCM dslots
, SCM cpl
)
378 register SCM res
= dslots
;
380 for (cpl
= SCM_CDR (cpl
); !scm_is_null (cpl
); cpl
= SCM_CDR (cpl
))
381 res
= scm_append (scm_list_2 (SCM_SLOT (SCM_CAR (cpl
),
382 scm_si_direct_slots
),
385 /* res contains a list of slots. Remove slots which appears more than once */
386 return remove_duplicate_slots (scm_reverse (res
), SCM_EOL
, SCM_EOL
);
393 while (!scm_is_null (ls
))
395 if (!scm_is_pair (SCM_CAR (ls
)))
396 SCM_SETCAR (ls
, scm_cons (SCM_CAR (ls
), SCM_EOL
));
403 SCM_DEFINE (scm_sys_compute_slots
, "%compute-slots", 1, 0, 0,
405 "Return a list consisting of the names of all slots belonging to\n"
406 "class @var{class}, i. e. the slots of @var{class} and of all of\n"
408 #define FUNC_NAME s_scm_sys_compute_slots
410 SCM_VALIDATE_CLASS (1, class);
411 return build_slots_list (SCM_SLOT (class, scm_si_direct_slots
),
412 SCM_SLOT (class, scm_si_cpl
));
417 /******************************************************************************
419 * compute-getters-n-setters
421 * This version doesn't handle slot options. It serves only for booting
422 * classes and will be overloaded in Scheme.
424 ******************************************************************************/
426 SCM_KEYWORD (k_init_value
, "init-value");
427 SCM_KEYWORD (k_init_thunk
, "init-thunk");
430 compute_getters_n_setters (SCM slots
)
436 for ( ; !scm_is_null (slots
); slots
= SCM_CDR (slots
))
438 SCM init
= SCM_BOOL_F
;
439 SCM options
= SCM_CDAR (slots
);
440 if (!scm_is_null (options
))
442 init
= scm_get_keyword (k_init_value
, options
, 0);
445 init
= scm_i_eval_x (scm_list_3 (scm_sym_lambda
,
447 scm_list_2 (scm_sym_quote
,
452 init
= scm_get_keyword (k_init_thunk
, options
, SCM_BOOL_F
);
454 *cdrloc
= scm_cons (scm_cons (SCM_CAAR (slots
),
456 scm_from_int (i
++))),
458 cdrloc
= SCM_CDRLOC (*cdrloc
);
463 /******************************************************************************
467 ******************************************************************************/
469 /*fixme* Manufacture keywords in advance */
471 scm_i_get_keyword (SCM key
, SCM l
, long len
, SCM default_value
, const char *subr
)
475 for (i
= 0; i
!= len
; i
+= 2)
477 SCM obj
= SCM_CAR (l
);
479 if (!scm_is_keyword (obj
))
480 scm_misc_error (subr
, "bad keyword: ~S", scm_list_1 (obj
));
481 else if (scm_is_eq (obj
, key
))
487 return default_value
;
491 SCM_DEFINE (scm_get_keyword
, "get-keyword", 3, 0, 0,
492 (SCM key
, SCM l
, SCM default_value
),
493 "Determine an associated value for the keyword @var{key} from\n"
494 "the list @var{l}. The list @var{l} has to consist of an even\n"
495 "number of elements, where, starting with the first, every\n"
496 "second element is a keyword, followed by its associated value.\n"
497 "If @var{l} does not hold a value for @var{key}, the value\n"
498 "@var{default_value} is returned.")
499 #define FUNC_NAME s_scm_get_keyword
503 SCM_ASSERT (scm_is_keyword (key
), key
, SCM_ARG1
, FUNC_NAME
);
504 len
= scm_ilength (l
);
505 if (len
< 0 || len
% 2 == 1)
506 scm_misc_error (FUNC_NAME
, "Bad keyword-value list: ~S", scm_list_1 (l
));
508 return scm_i_get_keyword (key
, l
, len
, default_value
, FUNC_NAME
);
513 SCM_KEYWORD (k_init_keyword
, "init-keyword");
515 static SCM
get_slot_value (SCM
class, SCM obj
, SCM slotdef
);
516 static SCM
set_slot_value (SCM
class, SCM obj
, SCM slotdef
, SCM value
);
518 SCM_DEFINE (scm_sys_initialize_object
, "%initialize-object", 2, 0, 0,
519 (SCM obj
, SCM initargs
),
520 "Initialize the object @var{obj} with the given arguments\n"
522 #define FUNC_NAME s_scm_sys_initialize_object
524 SCM tmp
, get_n_set
, slots
;
525 SCM
class = SCM_CLASS_OF (obj
);
528 SCM_VALIDATE_INSTANCE (1, obj
);
529 n_initargs
= scm_ilength (initargs
);
530 SCM_ASSERT ((n_initargs
& 1) == 0, initargs
, SCM_ARG2
, FUNC_NAME
);
532 get_n_set
= SCM_SLOT (class, scm_si_getters_n_setters
);
533 slots
= SCM_SLOT (class, scm_si_slots
);
535 /* See for each slot how it must be initialized */
537 !scm_is_null (slots
);
538 get_n_set
= SCM_CDR (get_n_set
), slots
= SCM_CDR (slots
))
540 SCM slot_name
= SCM_CAR (slots
);
543 if (!scm_is_null (SCM_CDR (slot_name
)))
545 /* This slot admits (perhaps) to be initialized at creation time */
546 long n
= scm_ilength (SCM_CDR (slot_name
));
547 if (n
& 1) /* odd or -1 */
548 SCM_MISC_ERROR ("class contains bogus slot definition: ~S",
549 scm_list_1 (slot_name
));
550 tmp
= scm_i_get_keyword (k_init_keyword
,
555 slot_name
= SCM_CAR (slot_name
);
558 /* an initarg was provided for this slot */
559 if (!scm_is_keyword (tmp
))
560 SCM_MISC_ERROR ("initarg must be a keyword. It was ~S",
562 slot_value
= scm_i_get_keyword (tmp
,
571 /* set slot to provided value */
572 set_slot_value (class, obj
, SCM_CAR (get_n_set
), slot_value
);
575 /* set slot to its :init-form if it exists */
576 tmp
= SCM_CADAR (get_n_set
);
577 if (scm_is_true (tmp
))
579 slot_value
= get_slot_value (class, obj
, SCM_CAR (get_n_set
));
580 if (SCM_GOOPS_UNBOUNDP (slot_value
))
582 SCM env
= SCM_EXTEND_ENV (SCM_EOL
, SCM_EOL
, SCM_ENV (tmp
));
583 set_slot_value (class,
586 scm_eval_body (SCM_CLOSURE_BODY (tmp
), env
));
596 /* NOTE: The following macros are interdependent with code
597 * in goops.scm:compute-getters-n-setters
599 #define SCM_GNS_INSTANCE_ALLOCATED_P(gns) \
600 (SCM_I_INUMP (SCM_CDDR (gns)) \
601 || (scm_is_pair (SCM_CDDR (gns)) \
602 && scm_is_pair (SCM_CDDDR (gns)) \
603 && scm_is_pair (SCM_CDDDDR (gns))))
604 #define SCM_GNS_INDEX(gns) \
605 (SCM_I_INUMP (SCM_CDDR (gns)) \
606 ? SCM_I_INUM (SCM_CDDR (gns)) \
607 : scm_to_long (SCM_CAR (SCM_CDDDDR (gns))))
608 #define SCM_GNS_SIZE(gns) \
609 (SCM_I_INUMP (SCM_CDDR (gns)) \
611 : scm_to_long (SCM_CADR (SCM_CDDDDR (gns))))
613 SCM_KEYWORD (k_class
, "class");
614 SCM_KEYWORD (k_allocation
, "allocation");
615 SCM_KEYWORD (k_instance
, "instance");
617 SCM_DEFINE (scm_sys_prep_layout_x
, "%prep-layout!", 1, 0, 0,
620 #define FUNC_NAME s_scm_sys_prep_layout_x
622 SCM slots
, getters_n_setters
, nfields
;
623 unsigned long int n
, i
;
627 SCM_VALIDATE_INSTANCE (1, class);
628 slots
= SCM_SLOT (class, scm_si_slots
);
629 getters_n_setters
= SCM_SLOT (class, scm_si_getters_n_setters
);
630 nfields
= SCM_SLOT (class, scm_si_nfields
);
631 if (!SCM_I_INUMP (nfields
) || SCM_I_INUM (nfields
) < 0)
632 SCM_MISC_ERROR ("bad value in nfields slot: ~S",
633 scm_list_1 (nfields
));
634 n
= 2 * SCM_I_INUM (nfields
);
635 if (n
< sizeof (SCM_CLASS_CLASS_LAYOUT
) - 1
636 && SCM_SUBCLASSP (class, scm_class_class
))
637 SCM_MISC_ERROR ("class object doesn't have enough fields: ~S",
638 scm_list_1 (nfields
));
640 layout
= scm_i_make_string (n
, &s
);
642 while (scm_is_pair (getters_n_setters
))
644 if (SCM_GNS_INSTANCE_ALLOCATED_P (SCM_CAR (getters_n_setters
)))
647 int len
, index
, size
;
650 if (i
>= n
|| !scm_is_pair (slots
))
653 /* extract slot type */
654 len
= scm_ilength (SCM_CDAR (slots
));
655 type
= scm_i_get_keyword (k_class
, SCM_CDAR (slots
),
656 len
, SCM_BOOL_F
, FUNC_NAME
);
657 /* determine slot GC protection and access mode */
658 if (scm_is_false (type
))
665 if (!SCM_CLASSP (type
))
666 SCM_MISC_ERROR ("bad slot class", SCM_EOL
);
667 else if (SCM_SUBCLASSP (type
, scm_class_foreign_slot
))
669 if (SCM_SUBCLASSP (type
, scm_class_self
))
671 else if (SCM_SUBCLASSP (type
, scm_class_protected
))
676 if (SCM_SUBCLASSP (type
, scm_class_opaque
))
678 else if (SCM_SUBCLASSP (type
, scm_class_read_only
))
690 index
= SCM_GNS_INDEX (SCM_CAR (getters_n_setters
));
691 if (index
!= (i
>> 1))
693 size
= SCM_GNS_SIZE (SCM_CAR (getters_n_setters
));
701 slots
= SCM_CDR (slots
);
702 getters_n_setters
= SCM_CDR (getters_n_setters
);
704 if (!scm_is_null (slots
))
707 SCM_MISC_ERROR ("inconsistent getters-n-setters", SCM_EOL
);
709 SCM_SET_SLOT (class, scm_si_layout
, scm_string_to_symbol (layout
));
710 return SCM_UNSPECIFIED
;
714 static void prep_hashsets (SCM
);
716 SCM_DEFINE (scm_sys_inherit_magic_x
, "%inherit-magic!", 2, 0, 0,
717 (SCM
class, SCM dsupers
),
719 #define FUNC_NAME s_scm_sys_inherit_magic_x
723 SCM_VALIDATE_INSTANCE (1, class);
724 while (!scm_is_null (ls
))
726 SCM_ASSERT (scm_is_pair (ls
)
727 && SCM_INSTANCEP (SCM_CAR (ls
)),
731 flags
|= SCM_CLASS_FLAGS (SCM_CAR (ls
));
734 flags
&= SCM_CLASSF_INHERIT
;
735 if (flags
& SCM_CLASSF_ENTITY
)
736 SCM_SET_CLASS_DESTRUCTOR (class, scm_struct_free_entity
);
739 long n
= SCM_I_INUM (SCM_SLOT (class, scm_si_nfields
));
742 * We could avoid calling scm_gc_malloc in the allocation code
743 * (in which case the following two lines are needed). Instead
744 * we make 0-slot instances non-light, so that the light case
745 * can be handled without special cases.
748 SCM_SET_CLASS_DESTRUCTOR (class, scm_struct_free_0
);
750 if (n
> 0 && !(flags
& SCM_CLASSF_METACLASS
))
752 /* NOTE: The following depends on scm_struct_i_size. */
753 flags
|= SCM_STRUCTF_LIGHT
+ n
* sizeof (SCM
); /* use light representation */
754 SCM_SET_CLASS_DESTRUCTOR (class, scm_struct_free_light
);
757 SCM_SET_CLASS_FLAGS (class, flags
);
759 prep_hashsets (class);
761 return SCM_UNSPECIFIED
;
766 prep_hashsets (SCM
class)
770 for (i
= 0; i
< 7; ++i
)
771 SCM_SET_HASHSET (class, i
, scm_c_uniform32 (goops_rstate
));
774 /******************************************************************************/
777 scm_basic_basic_make_class (SCM
class, SCM name
, SCM dsupers
, SCM dslots
)
779 SCM z
, cpl
, slots
, nfields
, g_n_s
;
781 /* Allocate one instance */
782 z
= scm_make_struct (class, SCM_INUM0
, SCM_EOL
);
784 /* Initialize its slots */
785 SCM_SET_SLOT (z
, scm_si_direct_supers
, dsupers
);
786 cpl
= compute_cpl (z
);
787 slots
= build_slots_list (maplist (dslots
), cpl
);
788 nfields
= scm_from_int (scm_ilength (slots
));
789 g_n_s
= compute_getters_n_setters (slots
);
791 SCM_SET_SLOT (z
, scm_si_name
, name
);
792 SCM_SET_SLOT (z
, scm_si_direct_slots
, dslots
);
793 SCM_SET_SLOT (z
, scm_si_direct_subclasses
, SCM_EOL
);
794 SCM_SET_SLOT (z
, scm_si_direct_methods
, SCM_EOL
);
795 SCM_SET_SLOT (z
, scm_si_cpl
, cpl
);
796 SCM_SET_SLOT (z
, scm_si_slots
, slots
);
797 SCM_SET_SLOT (z
, scm_si_nfields
, nfields
);
798 SCM_SET_SLOT (z
, scm_si_getters_n_setters
, g_n_s
);
799 SCM_SET_SLOT (z
, scm_si_redefined
, SCM_BOOL_F
);
800 SCM_SET_SLOT (z
, scm_si_environment
,
801 scm_top_level_env (SCM_TOP_LEVEL_LOOKUP_CLOSURE
));
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
)));
812 /* Support for the underlying structs: */
813 SCM_SET_CLASS_FLAGS (z
, (class == scm_class_entity_class
814 ? (SCM_CLASSF_GOOPS_OR_VALID
815 | SCM_CLASSF_OPERATOR
817 : class == scm_class_operator_class
818 ? SCM_CLASSF_GOOPS_OR_VALID
| SCM_CLASSF_OPERATOR
819 : SCM_CLASSF_GOOPS_OR_VALID
));
824 scm_basic_make_class (SCM
class, SCM name
, SCM dsupers
, SCM dslots
)
826 SCM z
= scm_basic_basic_make_class (class, name
, dsupers
, dslots
);
827 scm_sys_inherit_magic_x (z
, dsupers
);
828 scm_sys_prep_layout_x (z
);
832 /******************************************************************************/
834 SCM_SYMBOL (sym_layout
, "layout");
835 SCM_SYMBOL (sym_vcell
, "vcell");
836 SCM_SYMBOL (sym_vtable
, "vtable");
837 SCM_SYMBOL (sym_print
, "print");
838 SCM_SYMBOL (sym_procedure
, "procedure");
839 SCM_SYMBOL (sym_setter
, "setter");
840 SCM_SYMBOL (sym_redefined
, "redefined");
841 SCM_SYMBOL (sym_h0
, "h0");
842 SCM_SYMBOL (sym_h1
, "h1");
843 SCM_SYMBOL (sym_h2
, "h2");
844 SCM_SYMBOL (sym_h3
, "h3");
845 SCM_SYMBOL (sym_h4
, "h4");
846 SCM_SYMBOL (sym_h5
, "h5");
847 SCM_SYMBOL (sym_h6
, "h6");
848 SCM_SYMBOL (sym_h7
, "h7");
849 SCM_SYMBOL (sym_name
, "name");
850 SCM_SYMBOL (sym_direct_supers
, "direct-supers");
851 SCM_SYMBOL (sym_direct_slots
, "direct-slots");
852 SCM_SYMBOL (sym_direct_subclasses
, "direct-subclasses");
853 SCM_SYMBOL (sym_direct_methods
, "direct-methods");
854 SCM_SYMBOL (sym_cpl
, "cpl");
855 SCM_SYMBOL (sym_default_slot_definition_class
, "default-slot-definition-class");
856 SCM_SYMBOL (sym_slots
, "slots");
857 SCM_SYMBOL (sym_getters_n_setters
, "getters-n-setters");
858 SCM_SYMBOL (sym_keyword_access
, "keyword-access");
859 SCM_SYMBOL (sym_nfields
, "nfields");
860 SCM_SYMBOL (sym_environment
, "environment");
864 build_class_class_slots ()
867 scm_list_3 (sym_layout
, k_class
, scm_class_protected_read_only
),
868 scm_list_3 (sym_vtable
, k_class
, scm_class_self
),
869 scm_list_1 (sym_print
),
870 scm_list_3 (sym_procedure
, k_class
, scm_class_protected_opaque
),
871 scm_list_3 (sym_setter
, k_class
, scm_class_protected_opaque
),
872 scm_list_1 (sym_redefined
),
873 scm_list_3 (sym_h0
, k_class
, scm_class_int
),
874 scm_list_3 (sym_h1
, k_class
, scm_class_int
),
875 scm_list_3 (sym_h2
, k_class
, scm_class_int
),
876 scm_list_3 (sym_h3
, k_class
, scm_class_int
),
877 scm_list_3 (sym_h4
, k_class
, scm_class_int
),
878 scm_list_3 (sym_h5
, k_class
, scm_class_int
),
879 scm_list_3 (sym_h6
, k_class
, scm_class_int
),
880 scm_list_3 (sym_h7
, k_class
, scm_class_int
),
881 scm_list_1 (sym_name
),
882 scm_list_1 (sym_direct_supers
),
883 scm_list_1 (sym_direct_slots
),
884 scm_list_1 (sym_direct_subclasses
),
885 scm_list_1 (sym_direct_methods
),
886 scm_list_1 (sym_cpl
),
887 scm_list_1 (sym_default_slot_definition_class
),
888 scm_list_1 (sym_slots
),
889 scm_list_1 (sym_getters_n_setters
),
890 scm_list_1 (sym_keyword_access
),
891 scm_list_1 (sym_nfields
),
892 scm_list_1 (sym_environment
),
897 create_basic_classes (void)
899 /* SCM slots_of_class = build_class_class_slots (); */
901 /**** <scm_class_class> ****/
902 SCM cs
= scm_from_locale_string (SCM_CLASS_CLASS_LAYOUT
903 + 2 * scm_vtable_offset_user
);
904 SCM name
= scm_from_locale_symbol ("<class>");
905 scm_class_class
= scm_permanent_object (scm_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_si_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); */
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); */
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)); */
921 SCM_SET_SLOT (scm_class_class
, scm_si_redefined
, SCM_BOOL_F
);
922 SCM_SET_SLOT (scm_class_class
, scm_si_environment
,
923 scm_top_level_env (SCM_TOP_LEVEL_LOOKUP_CLOSURE
));
925 prep_hashsets (scm_class_class
);
927 DEFVAR(name
, scm_class_class
);
929 /**** <scm_class_top> ****/
930 name
= scm_from_locale_symbol ("<top>");
931 scm_class_top
= scm_permanent_object (scm_basic_make_class (scm_class_class
,
936 DEFVAR(name
, scm_class_top
);
938 /**** <scm_class_object> ****/
939 name
= scm_from_locale_symbol ("<object>");
940 scm_class_object
= scm_permanent_object (scm_basic_make_class (scm_class_class
,
942 scm_list_1 (scm_class_top
),
945 DEFVAR (name
, scm_class_object
);
947 /* <top> <object> and <class> were partially initialized. Correct them here */
948 SCM_SET_SLOT (scm_class_object
, scm_si_direct_subclasses
, scm_list_1 (scm_class_class
));
950 SCM_SET_SLOT (scm_class_class
, scm_si_direct_supers
, scm_list_1 (scm_class_object
));
951 SCM_SET_SLOT (scm_class_class
, scm_si_cpl
, scm_list_3 (scm_class_class
, scm_class_object
, scm_class_top
));
954 /******************************************************************************/
956 SCM_DEFINE (scm_instance_p
, "instance?", 1, 0, 0,
958 "Return @code{#t} if @var{obj} is an instance.")
959 #define FUNC_NAME s_scm_instance_p
961 return scm_from_bool (SCM_INSTANCEP (obj
));
966 /******************************************************************************
968 * Meta object accessors
970 ******************************************************************************/
971 SCM_DEFINE (scm_class_name
, "class-name", 1, 0, 0,
973 "Return the class name of @var{obj}.")
974 #define FUNC_NAME s_scm_class_name
976 SCM_VALIDATE_CLASS (1, obj
);
977 return scm_slot_ref (obj
, sym_name
);
981 SCM_DEFINE (scm_class_direct_supers
, "class-direct-supers", 1, 0, 0,
983 "Return the direct superclasses of the class @var{obj}.")
984 #define FUNC_NAME s_scm_class_direct_supers
986 SCM_VALIDATE_CLASS (1, obj
);
987 return scm_slot_ref (obj
, sym_direct_supers
);
991 SCM_DEFINE (scm_class_direct_slots
, "class-direct-slots", 1, 0, 0,
993 "Return the direct slots of the class @var{obj}.")
994 #define FUNC_NAME s_scm_class_direct_slots
996 SCM_VALIDATE_CLASS (1, obj
);
997 return scm_slot_ref (obj
, sym_direct_slots
);
1001 SCM_DEFINE (scm_class_direct_subclasses
, "class-direct-subclasses", 1, 0, 0,
1003 "Return the direct subclasses of the class @var{obj}.")
1004 #define FUNC_NAME s_scm_class_direct_subclasses
1006 SCM_VALIDATE_CLASS (1, obj
);
1007 return scm_slot_ref(obj
, sym_direct_subclasses
);
1011 SCM_DEFINE (scm_class_direct_methods
, "class-direct-methods", 1, 0, 0,
1013 "Return the direct methods of the class @var{obj}")
1014 #define FUNC_NAME s_scm_class_direct_methods
1016 SCM_VALIDATE_CLASS (1, obj
);
1017 return scm_slot_ref (obj
, sym_direct_methods
);
1021 SCM_DEFINE (scm_class_precedence_list
, "class-precedence-list", 1, 0, 0,
1023 "Return the class precedence list of the class @var{obj}.")
1024 #define FUNC_NAME s_scm_class_precedence_list
1026 SCM_VALIDATE_CLASS (1, obj
);
1027 return scm_slot_ref (obj
, sym_cpl
);
1031 SCM_DEFINE (scm_class_slots
, "class-slots", 1, 0, 0,
1033 "Return the slot list of the class @var{obj}.")
1034 #define FUNC_NAME s_scm_class_slots
1036 SCM_VALIDATE_CLASS (1, obj
);
1037 return scm_slot_ref (obj
, sym_slots
);
1041 SCM_DEFINE (scm_class_environment
, "class-environment", 1, 0, 0,
1043 "Return the environment of the class @var{obj}.")
1044 #define FUNC_NAME s_scm_class_environment
1046 SCM_VALIDATE_CLASS (1, obj
);
1047 return scm_slot_ref(obj
, sym_environment
);
1052 SCM_DEFINE (scm_generic_function_name
, "generic-function-name", 1, 0, 0,
1054 "Return the name of the generic function @var{obj}.")
1055 #define FUNC_NAME s_scm_generic_function_name
1057 SCM_VALIDATE_GENERIC (1, obj
);
1058 return scm_procedure_property (obj
, scm_sym_name
);
1062 SCM_SYMBOL (sym_methods
, "methods");
1063 SCM_SYMBOL (sym_extended_by
, "extended-by");
1064 SCM_SYMBOL (sym_extends
, "extends");
1067 SCM
fold_downward_gf_methods (SCM method_lists
, SCM gf
)
1069 SCM gfs
= scm_slot_ref (gf
, sym_extended_by
);
1070 method_lists
= scm_cons (scm_slot_ref (gf
, sym_methods
), method_lists
);
1071 while (!scm_is_null (gfs
))
1073 method_lists
= fold_downward_gf_methods (method_lists
, SCM_CAR (gfs
));
1074 gfs
= SCM_CDR (gfs
);
1076 return method_lists
;
1080 SCM
fold_upward_gf_methods (SCM method_lists
, SCM gf
)
1082 if (SCM_IS_A_P (gf
, scm_class_extended_generic
))
1084 SCM gfs
= scm_slot_ref (gf
, sym_extends
);
1085 while (!scm_is_null (gfs
))
1087 SCM methods
= scm_slot_ref (SCM_CAR (gfs
), sym_methods
);
1088 method_lists
= fold_upward_gf_methods (scm_cons (methods
,
1091 gfs
= SCM_CDR (gfs
);
1094 return method_lists
;
1097 SCM_DEFINE (scm_generic_function_methods
, "generic-function-methods", 1, 0, 0,
1099 "Return the methods of the generic function @var{obj}.")
1100 #define FUNC_NAME s_scm_generic_function_methods
1103 SCM_VALIDATE_GENERIC (1, obj
);
1104 methods
= fold_upward_gf_methods (SCM_EOL
, obj
);
1105 methods
= fold_downward_gf_methods (methods
, obj
);
1106 return scm_append (methods
);
1110 SCM_DEFINE (scm_method_generic_function
, "method-generic-function", 1, 0, 0,
1112 "Return the generic function for the method @var{obj}.")
1113 #define FUNC_NAME s_scm_method_generic_function
1115 SCM_VALIDATE_METHOD (1, obj
);
1116 return scm_slot_ref (obj
, scm_from_locale_symbol ("generic-function"));
1120 SCM_DEFINE (scm_method_specializers
, "method-specializers", 1, 0, 0,
1122 "Return specializers of the method @var{obj}.")
1123 #define FUNC_NAME s_scm_method_specializers
1125 SCM_VALIDATE_METHOD (1, obj
);
1126 return scm_slot_ref (obj
, scm_from_locale_symbol ("specializers"));
1130 SCM_DEFINE (scm_method_procedure
, "method-procedure", 1, 0, 0,
1132 "Return the procedure of the method @var{obj}.")
1133 #define FUNC_NAME s_scm_method_procedure
1135 SCM_VALIDATE_METHOD (1, obj
);
1136 return scm_slot_ref (obj
, sym_procedure
);
1140 SCM_DEFINE (scm_accessor_method_slot_definition
, "accessor-method-slot-definition", 1, 0, 0,
1142 "Return the slot definition of the accessor @var{obj}.")
1143 #define FUNC_NAME s_scm_accessor_method_slot_definition
1145 SCM_VALIDATE_ACCESSOR (1, obj
);
1146 return scm_slot_ref (obj
, scm_from_locale_symbol ("slot-definition"));
1150 SCM_DEFINE (scm_sys_tag_body
, "%tag-body", 1, 0, 0,
1152 "Internal GOOPS magic---don't use this function!")
1153 #define FUNC_NAME s_scm_sys_tag_body
1155 return scm_cons (SCM_IM_LAMBDA
, body
);
1159 /******************************************************************************
1161 * S l o t a c c e s s
1163 ******************************************************************************/
1165 SCM_DEFINE (scm_make_unbound
, "make-unbound", 0, 0, 0,
1167 "Return the unbound value.")
1168 #define FUNC_NAME s_scm_make_unbound
1170 return SCM_GOOPS_UNBOUND
;
1174 SCM_DEFINE (scm_unbound_p
, "unbound?", 1, 0, 0,
1176 "Return @code{#t} if @var{obj} is unbound.")
1177 #define FUNC_NAME s_scm_unbound_p
1179 return SCM_GOOPS_UNBOUNDP (obj
) ? SCM_BOOL_T
: SCM_BOOL_F
;
1183 SCM_DEFINE (scm_assert_bound
, "assert-bound", 2, 0, 0,
1184 (SCM value
, SCM obj
),
1185 "Return @var{value} if it is bound, and invoke the\n"
1186 "@var{slot-unbound} method of @var{obj} if it is not.")
1187 #define FUNC_NAME s_scm_assert_bound
1189 if (SCM_GOOPS_UNBOUNDP (value
))
1190 return CALL_GF1 ("slot-unbound", obj
);
1195 SCM_DEFINE (scm_at_assert_bound_ref
, "@assert-bound-ref", 2, 0, 0,
1196 (SCM obj
, SCM index
),
1197 "Like @code{assert-bound}, but use @var{index} for accessing\n"
1198 "the value from @var{obj}.")
1199 #define FUNC_NAME s_scm_at_assert_bound_ref
1201 SCM value
= SCM_SLOT (obj
, scm_to_int (index
));
1202 if (SCM_GOOPS_UNBOUNDP (value
))
1203 return CALL_GF1 ("slot-unbound", obj
);
1208 SCM_DEFINE (scm_sys_fast_slot_ref
, "%fast-slot-ref", 2, 0, 0,
1209 (SCM obj
, SCM index
),
1210 "Return the slot value with index @var{index} from @var{obj}.")
1211 #define FUNC_NAME s_scm_sys_fast_slot_ref
1213 unsigned long int i
;
1215 SCM_VALIDATE_INSTANCE (1, obj
);
1216 i
= scm_to_unsigned_integer (index
, 0, SCM_NUMBER_OF_SLOTS(obj
)-1);
1217 return SCM_SLOT (obj
, i
);
1221 SCM_DEFINE (scm_sys_fast_slot_set_x
, "%fast-slot-set!", 3, 0, 0,
1222 (SCM obj
, SCM index
, SCM value
),
1223 "Set the slot with index @var{index} in @var{obj} to\n"
1225 #define FUNC_NAME s_scm_sys_fast_slot_set_x
1227 unsigned long int i
;
1229 SCM_VALIDATE_INSTANCE (1, obj
);
1230 i
= scm_to_unsigned_integer (index
, 0, SCM_NUMBER_OF_SLOTS(obj
)-1);
1232 SCM_SET_SLOT (obj
, i
, value
);
1234 return SCM_UNSPECIFIED
;
1239 SCM_SYNTAX (s_atslot_ref
, "@slot-ref", scm_i_makbimacro
, scm_m_atslot_ref
);
1240 SCM_SYNTAX (s_atslot_set_x
, "@slot-set!", scm_i_makbimacro
, scm_m_atslot_set_x
);
1245 /* In the future, this function will return the effective slot
1246 * definition associated with SLOT_NAME. Now it just returns some of
1247 * the information which will be stored in the effective slot
1252 slot_definition_using_name (SCM
class, SCM slot_name
)
1254 register SCM slots
= SCM_SLOT (class, scm_si_getters_n_setters
);
1255 for (; !scm_is_null (slots
); slots
= SCM_CDR (slots
))
1256 if (SCM_CAAR (slots
) == slot_name
)
1257 return SCM_CAR (slots
);
1262 get_slot_value (SCM
class SCM_UNUSED
, SCM obj
, SCM slotdef
)
1264 SCM access
= SCM_CDDR (slotdef
);
1266 * - access is an integer (the offset of this slot in the slots vector)
1267 * - otherwise (car access) is the getter function to apply
1269 * Instances have never more than SCM_MOST_POSITIVE_FIXNUM slots, so
1270 * we can just assume fixnums here.
1272 if (SCM_I_INUMP (access
))
1273 return SCM_SLOT (obj
, SCM_I_INUM (access
));
1276 /* We must evaluate (apply (car access) (list obj))
1277 * where (car access) is known to be a closure of arity 1 */
1278 register SCM code
, env
;
1280 code
= SCM_CAR (access
);
1281 if (!SCM_CLOSUREP (code
))
1282 return SCM_SUBRF (code
) (obj
);
1283 env
= SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (code
),
1286 /* Evaluate the closure body */
1287 return scm_eval_body (SCM_CLOSURE_BODY (code
), env
);
1292 get_slot_value_using_name (SCM
class, SCM obj
, SCM slot_name
)
1294 SCM slotdef
= slot_definition_using_name (class, slot_name
);
1295 if (scm_is_true (slotdef
))
1296 return get_slot_value (class, obj
, slotdef
);
1298 return CALL_GF3 ("slot-missing", class, obj
, slot_name
);
1302 set_slot_value (SCM
class SCM_UNUSED
, SCM obj
, SCM slotdef
, SCM value
)
1304 SCM access
= SCM_CDDR (slotdef
);
1306 * - access is an integer (the offset of this slot in the slots vector)
1307 * - otherwise (cadr access) is the setter function to apply
1309 * Instances have never more than SCM_MOST_POSITIVE_FIXNUM slots, so
1310 * we can just assume fixnums here.
1312 if (SCM_I_INUMP (access
))
1313 SCM_SET_SLOT (obj
, SCM_I_INUM (access
), value
);
1316 /* We must evaluate (apply (cadr l) (list obj value))
1317 * where (cadr l) is known to be a closure of arity 2 */
1318 register SCM code
, env
;
1320 code
= SCM_CADR (access
);
1321 if (!SCM_CLOSUREP (code
))
1322 SCM_SUBRF (code
) (obj
, value
);
1325 env
= SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (code
),
1326 scm_list_2 (obj
, value
),
1328 /* Evaluate the closure body */
1329 scm_eval_body (SCM_CLOSURE_BODY (code
), env
);
1332 return SCM_UNSPECIFIED
;
1336 set_slot_value_using_name (SCM
class, SCM obj
, SCM slot_name
, SCM value
)
1338 SCM slotdef
= slot_definition_using_name (class, slot_name
);
1339 if (scm_is_true (slotdef
))
1340 return set_slot_value (class, obj
, slotdef
, value
);
1342 return CALL_GF4 ("slot-missing", class, obj
, slot_name
, value
);
1346 test_slot_existence (SCM
class SCM_UNUSED
, SCM obj
, SCM slot_name
)
1350 for (l
= SCM_ACCESSORS_OF (obj
); !scm_is_null (l
); l
= SCM_CDR (l
))
1351 if (scm_is_eq (SCM_CAAR (l
), slot_name
))
1357 /* ======================================== */
1359 SCM_DEFINE (scm_slot_ref_using_class
, "slot-ref-using-class", 3, 0, 0,
1360 (SCM
class, SCM obj
, SCM slot_name
),
1362 #define FUNC_NAME s_scm_slot_ref_using_class
1366 SCM_VALIDATE_CLASS (1, class);
1367 SCM_VALIDATE_INSTANCE (2, obj
);
1368 SCM_VALIDATE_SYMBOL (3, slot_name
);
1370 res
= get_slot_value_using_name (class, obj
, slot_name
);
1371 if (SCM_GOOPS_UNBOUNDP (res
))
1372 return CALL_GF3 ("slot-unbound", class, obj
, slot_name
);
1378 SCM_DEFINE (scm_slot_set_using_class_x
, "slot-set-using-class!", 4, 0, 0,
1379 (SCM
class, SCM obj
, SCM slot_name
, SCM value
),
1381 #define FUNC_NAME s_scm_slot_set_using_class_x
1383 SCM_VALIDATE_CLASS (1, class);
1384 SCM_VALIDATE_INSTANCE (2, obj
);
1385 SCM_VALIDATE_SYMBOL (3, slot_name
);
1387 return set_slot_value_using_name (class, obj
, slot_name
, value
);
1392 SCM_DEFINE (scm_slot_bound_using_class_p
, "slot-bound-using-class?", 3, 0, 0,
1393 (SCM
class, SCM obj
, SCM slot_name
),
1395 #define FUNC_NAME s_scm_slot_bound_using_class_p
1397 SCM_VALIDATE_CLASS (1, class);
1398 SCM_VALIDATE_INSTANCE (2, obj
);
1399 SCM_VALIDATE_SYMBOL (3, slot_name
);
1401 return (SCM_GOOPS_UNBOUNDP (get_slot_value_using_name (class, obj
, slot_name
))
1407 SCM_DEFINE (scm_slot_exists_using_class_p
, "slot-exists-using-class?", 3, 0, 0,
1408 (SCM
class, SCM obj
, SCM slot_name
),
1410 #define FUNC_NAME s_scm_slot_exists_using_class_p
1412 SCM_VALIDATE_CLASS (1, class);
1413 SCM_VALIDATE_INSTANCE (2, obj
);
1414 SCM_VALIDATE_SYMBOL (3, slot_name
);
1415 return test_slot_existence (class, obj
, slot_name
);
1420 /* ======================================== */
1422 SCM_DEFINE (scm_slot_ref
, "slot-ref", 2, 0, 0,
1423 (SCM obj
, SCM slot_name
),
1424 "Return the value from @var{obj}'s slot with the name\n"
1426 #define FUNC_NAME s_scm_slot_ref
1430 SCM_VALIDATE_INSTANCE (1, obj
);
1431 TEST_CHANGE_CLASS (obj
, class);
1433 res
= get_slot_value_using_name (class, obj
, slot_name
);
1434 if (SCM_GOOPS_UNBOUNDP (res
))
1435 return CALL_GF3 ("slot-unbound", class, obj
, slot_name
);
1440 SCM_DEFINE (scm_slot_set_x
, "slot-set!", 3, 0, 0,
1441 (SCM obj
, SCM slot_name
, SCM value
),
1442 "Set the slot named @var{slot_name} of @var{obj} to @var{value}.")
1443 #define FUNC_NAME s_scm_slot_set_x
1447 SCM_VALIDATE_INSTANCE (1, obj
);
1448 TEST_CHANGE_CLASS(obj
, class);
1450 return set_slot_value_using_name (class, obj
, slot_name
, value
);
1454 const char *scm_s_slot_set_x
= s_scm_slot_set_x
;
1456 SCM_DEFINE (scm_slot_bound_p
, "slot-bound?", 2, 0, 0,
1457 (SCM obj
, SCM slot_name
),
1458 "Return @code{#t} if the slot named @var{slot_name} of @var{obj}\n"
1460 #define FUNC_NAME s_scm_slot_bound_p
1464 SCM_VALIDATE_INSTANCE (1, obj
);
1465 TEST_CHANGE_CLASS(obj
, class);
1467 return (SCM_GOOPS_UNBOUNDP (get_slot_value_using_name (class,
1475 SCM_DEFINE (scm_slot_exists_p
, "slot-exists?", 2, 0, 0,
1476 (SCM obj
, SCM slot_name
),
1477 "Return @code{#t} if @var{obj} has a slot named @var{slot_name}.")
1478 #define FUNC_NAME s_scm_slot_exists_p
1482 SCM_VALIDATE_INSTANCE (1, obj
);
1483 SCM_VALIDATE_SYMBOL (2, slot_name
);
1484 TEST_CHANGE_CLASS (obj
, class);
1486 return test_slot_existence (class, obj
, slot_name
);
1491 /******************************************************************************
1493 * %allocate-instance (the low level instance allocation primitive)
1495 ******************************************************************************/
1497 static void clear_method_cache (SCM
);
1500 wrap_init (SCM
class, SCM
*m
, long n
)
1504 /* Set all slots to unbound */
1505 for (i
= 0; i
< n
; i
++)
1506 m
[i
] = SCM_GOOPS_UNBOUND
;
1508 return scm_double_cell ((((scm_t_bits
) SCM_STRUCT_DATA (class))
1510 (scm_t_bits
) m
, 0, 0);
1513 SCM_DEFINE (scm_sys_allocate_instance
, "%allocate-instance", 2, 0, 0,
1514 (SCM
class, SCM initargs
),
1515 "Create a new instance of class @var{class} and initialize it\n"
1516 "from the arguments @var{initargs}.")
1517 #define FUNC_NAME s_scm_sys_allocate_instance
1522 SCM_VALIDATE_CLASS (1, class);
1524 /* Most instances */
1525 if (SCM_CLASS_FLAGS (class) & SCM_STRUCTF_LIGHT
)
1527 n
= SCM_I_INUM (SCM_SLOT (class, scm_si_nfields
));
1528 m
= (SCM
*) scm_gc_malloc (n
* sizeof (SCM
), "struct");
1529 return wrap_init (class, m
, n
);
1532 /* Foreign objects */
1533 if (SCM_CLASS_FLAGS (class) & SCM_CLASSF_FOREIGN
)
1534 return scm_make_foreign_object (class, initargs
);
1536 n
= SCM_I_INUM (SCM_SLOT (class, scm_si_nfields
));
1539 if (SCM_CLASS_FLAGS (class) & SCM_CLASSF_ENTITY
)
1541 m
= (SCM
*) scm_alloc_struct (n
, scm_struct_entity_n_extra_words
,
1543 m
[scm_struct_i_setter
] = SCM_BOOL_F
;
1544 m
[scm_struct_i_procedure
] = SCM_BOOL_F
;
1545 /* Generic functions */
1546 if (SCM_CLASS_FLAGS (class) & SCM_CLASSF_PURE_GENERIC
)
1548 SCM gf
= wrap_init (class, m
, n
);
1549 clear_method_cache (gf
);
1553 return wrap_init (class, m
, n
);
1557 if (SCM_CLASS_FLAGS (class) & SCM_CLASSF_METACLASS
)
1561 /* allocate class object */
1562 SCM z
= scm_make_struct (class, SCM_INUM0
, SCM_EOL
);
1564 SCM_SET_SLOT (z
, scm_si_print
, SCM_GOOPS_UNBOUND
);
1565 for (i
= scm_si_goops_fields
; i
< n
; i
++)
1566 SCM_SET_SLOT (z
, i
, SCM_GOOPS_UNBOUND
);
1568 if (SCM_SUBCLASSP (class, scm_class_entity_class
))
1569 SCM_SET_CLASS_FLAGS (z
, SCM_CLASSF_OPERATOR
| SCM_CLASSF_ENTITY
);
1570 else if (SCM_SUBCLASSP (class, scm_class_operator_class
))
1571 SCM_SET_CLASS_FLAGS (z
, SCM_CLASSF_OPERATOR
);
1576 /* Non-light instances */
1578 m
= (SCM
*) scm_alloc_struct (n
, scm_struct_n_extra_words
, "heavy struct");
1579 return wrap_init (class, m
, n
);
1584 SCM_DEFINE (scm_sys_set_object_setter_x
, "%set-object-setter!", 2, 0, 0,
1585 (SCM obj
, SCM setter
),
1587 #define FUNC_NAME s_scm_sys_set_object_setter_x
1589 SCM_ASSERT (SCM_STRUCTP (obj
)
1590 && ((SCM_CLASS_FLAGS (obj
) & SCM_CLASSF_OPERATOR
)
1591 || SCM_I_ENTITYP (obj
)),
1595 if (SCM_I_ENTITYP (obj
))
1596 SCM_SET_ENTITY_SETTER (obj
, setter
);
1598 SCM_OPERATOR_CLASS (obj
)->setter
= setter
;
1599 return SCM_UNSPECIFIED
;
1603 /******************************************************************************
1605 * %modify-instance (used by change-class to modify in place)
1607 ******************************************************************************/
1609 SCM_DEFINE (scm_sys_modify_instance
, "%modify-instance", 2, 0, 0,
1612 #define FUNC_NAME s_scm_sys_modify_instance
1614 SCM_VALIDATE_INSTANCE (1, old
);
1615 SCM_VALIDATE_INSTANCE (2, new);
1617 /* Exchange the data contained in old and new. We exchange rather than
1618 * scratch the old value with new to be correct with GC.
1619 * See "Class redefinition protocol above".
1621 SCM_CRITICAL_SECTION_START
;
1623 SCM car
= SCM_CAR (old
);
1624 SCM cdr
= SCM_CDR (old
);
1625 SCM_SETCAR (old
, SCM_CAR (new));
1626 SCM_SETCDR (old
, SCM_CDR (new));
1627 SCM_SETCAR (new, car
);
1628 SCM_SETCDR (new, cdr
);
1630 SCM_CRITICAL_SECTION_END
;
1631 return SCM_UNSPECIFIED
;
1635 SCM_DEFINE (scm_sys_modify_class
, "%modify-class", 2, 0, 0,
1638 #define FUNC_NAME s_scm_sys_modify_class
1640 SCM_VALIDATE_CLASS (1, old
);
1641 SCM_VALIDATE_CLASS (2, new);
1643 SCM_CRITICAL_SECTION_START
;
1645 SCM car
= SCM_CAR (old
);
1646 SCM cdr
= SCM_CDR (old
);
1647 SCM_SETCAR (old
, SCM_CAR (new));
1648 SCM_SETCDR (old
, SCM_CDR (new));
1649 SCM_STRUCT_DATA (old
)[scm_vtable_index_vtable
] = SCM_UNPACK (old
);
1650 SCM_SETCAR (new, car
);
1651 SCM_SETCDR (new, cdr
);
1652 SCM_STRUCT_DATA (new)[scm_vtable_index_vtable
] = SCM_UNPACK (new);
1654 SCM_CRITICAL_SECTION_END
;
1655 return SCM_UNSPECIFIED
;
1659 SCM_DEFINE (scm_sys_invalidate_class
, "%invalidate-class", 1, 0, 0,
1662 #define FUNC_NAME s_scm_sys_invalidate_class
1664 SCM_VALIDATE_CLASS (1, class);
1665 SCM_CLEAR_CLASS_FLAGS (class, SCM_CLASSF_GOOPS_VALID
);
1666 return SCM_UNSPECIFIED
;
1670 /* When instances change class, they finally get a new body, but
1671 * before that, they go through purgatory in hell. Odd as it may
1672 * seem, this data structure saves us from eternal suffering in
1673 * infinite recursions.
1676 static scm_t_bits
**hell
;
1677 static long n_hell
= 1; /* one place for the evil one himself */
1678 static long hell_size
= 4;
1679 static SCM hell_mutex
;
1685 for (i
= 1; i
< n_hell
; ++i
)
1686 if (SCM_STRUCT_DATA (o
) == hell
[i
])
1692 go_to_hell (void *o
)
1694 SCM obj
= SCM_PACK ((scm_t_bits
) o
);
1695 scm_lock_mutex (hell_mutex
);
1696 if (n_hell
== hell_size
)
1698 long new_size
= 2 * hell_size
;
1699 hell
= scm_realloc (hell
, new_size
);
1700 hell_size
= new_size
;
1702 hell
[n_hell
++] = SCM_STRUCT_DATA (obj
);
1703 scm_unlock_mutex (hell_mutex
);
1707 go_to_heaven (void *o
)
1709 scm_lock_mutex (hell_mutex
);
1710 hell
[burnin (SCM_PACK ((scm_t_bits
) o
))] = hell
[--n_hell
];
1711 scm_unlock_mutex (hell_mutex
);
1715 SCM_SYMBOL (scm_sym_change_class
, "change-class");
1718 purgatory (void *args
)
1720 return scm_apply_0 (GETVAR (scm_sym_change_class
),
1721 SCM_PACK ((scm_t_bits
) args
));
1724 /* This function calls the generic function change-class for all
1725 * instances which aren't currently undergoing class change.
1729 scm_change_object_class (SCM obj
, SCM old_class SCM_UNUSED
, SCM new_class
)
1732 scm_internal_dynamic_wind (go_to_hell
, purgatory
, go_to_heaven
,
1733 (void *) SCM_UNPACK (scm_list_2 (obj
, new_class
)),
1734 (void *) SCM_UNPACK (obj
));
1737 /******************************************************************************
1743 * GGG E N E R I C F U N C T I O N S
1745 * This implementation provides
1746 * - generic functions (with class specializers)
1749 * - a hard-coded MOP for standard gf, which can be overloaded for non-std gf
1751 ******************************************************************************/
1753 SCM_KEYWORD (k_name
, "name");
1755 SCM_SYMBOL (sym_no_method
, "no-method");
1757 static SCM list_of_no_method
;
1759 SCM_GLOBAL_SYMBOL (scm_sym_args
, "args");
1763 scm_make_method_cache (SCM gf
)
1765 return scm_list_5 (SCM_IM_DISPATCH
,
1768 scm_c_make_vector (SCM_INITIAL_MCACHE_SIZE
,
1774 clear_method_cache (SCM gf
)
1776 SCM cache
= scm_make_method_cache (gf
);
1777 SCM_SET_ENTITY_PROCEDURE (gf
, cache
);
1778 SCM_SET_SLOT (gf
, scm_si_used_by
, SCM_BOOL_F
);
1781 SCM_DEFINE (scm_sys_invalidate_method_cache_x
, "%invalidate-method-cache!", 1, 0, 0,
1784 #define FUNC_NAME s_scm_sys_invalidate_method_cache_x
1787 SCM_ASSERT (SCM_PUREGENERICP (gf
), gf
, SCM_ARG1
, FUNC_NAME
);
1788 used_by
= SCM_SLOT (gf
, scm_si_used_by
);
1789 if (scm_is_true (used_by
))
1791 SCM methods
= SCM_SLOT (gf
, scm_si_methods
);
1792 for (; scm_is_pair (used_by
); used_by
= SCM_CDR (used_by
))
1793 scm_sys_invalidate_method_cache_x (SCM_CAR (used_by
));
1794 clear_method_cache (gf
);
1795 for (; scm_is_pair (methods
); methods
= SCM_CDR (methods
))
1796 SCM_SET_SLOT (SCM_CAR (methods
), scm_si_code_table
, SCM_EOL
);
1799 SCM n
= SCM_SLOT (gf
, scm_si_n_specialized
);
1800 /* The sign of n is a flag indicating rest args. */
1801 SCM_SET_MCACHE_N_SPECIALIZED (SCM_ENTITY_PROCEDURE (gf
), n
);
1803 return SCM_UNSPECIFIED
;
1807 SCM_DEFINE (scm_generic_capability_p
, "generic-capability?", 1, 0, 0,
1810 #define FUNC_NAME s_scm_generic_capability_p
1812 SCM_ASSERT (scm_is_true (scm_procedure_p (proc
)),
1813 proc
, SCM_ARG1
, FUNC_NAME
);
1814 return (scm_subr_p (proc
) && SCM_SUBR_GENERIC (proc
)
1820 SCM_DEFINE (scm_enable_primitive_generic_x
, "enable-primitive-generic!", 0, 0, 1,
1823 #define FUNC_NAME s_scm_enable_primitive_generic_x
1825 SCM_VALIDATE_REST_ARGUMENT (subrs
);
1826 while (!scm_is_null (subrs
))
1828 SCM subr
= SCM_CAR (subrs
);
1829 SCM_ASSERT (scm_subr_p (subr
) && SCM_SUBR_GENERIC (subr
),
1830 subr
, SCM_ARGn
, FUNC_NAME
);
1831 *SCM_SUBR_GENERIC (subr
)
1832 = scm_make (scm_list_3 (scm_class_generic
,
1835 subrs
= SCM_CDR (subrs
);
1837 return SCM_UNSPECIFIED
;
1841 SCM_DEFINE (scm_primitive_generic_generic
, "primitive-generic-generic", 1, 0, 0,
1844 #define FUNC_NAME s_scm_primitive_generic_generic
1846 if (scm_subr_p (subr
) && SCM_SUBR_GENERIC (subr
))
1848 if (!*SCM_SUBR_GENERIC (subr
))
1849 scm_enable_primitive_generic_x (scm_list_1 (subr
));
1850 return *SCM_SUBR_GENERIC (subr
);
1852 SCM_WRONG_TYPE_ARG (SCM_ARG1
, subr
);
1856 typedef struct t_extension
{
1857 struct t_extension
*next
;
1862 static t_extension
*extensions
= 0;
1864 SCM_VARIABLE (scm_var_make_extended_generic
, "make-extended-generic");
1867 scm_c_extend_primitive_generic (SCM extended
, SCM extension
)
1872 if (!*SCM_SUBR_GENERIC (extended
))
1873 scm_enable_primitive_generic_x (scm_list_1 (extended
));
1874 gf
= *SCM_SUBR_GENERIC (extended
);
1875 gext
= scm_call_2 (SCM_VARIABLE_REF (scm_var_make_extended_generic
),
1877 SCM_SNAME (extension
));
1878 *SCM_SUBR_GENERIC (extension
) = gext
;
1882 t_extension
*e
= scm_malloc (sizeof (t_extension
));
1883 t_extension
**loc
= &extensions
;
1884 /* Make sure that extensions are placed before their own
1885 * extensions in the extensions list. O(N^2) algorithm, but
1886 * extensions of primitive generics are rare.
1888 while (*loc
&& extension
!= (*loc
)->extended
)
1889 loc
= &(*loc
)->next
;
1891 e
->extended
= extended
;
1892 e
->extension
= extension
;
1898 setup_extended_primitive_generics ()
1902 t_extension
*e
= extensions
;
1903 scm_c_extend_primitive_generic (e
->extended
, e
->extension
);
1904 extensions
= e
->next
;
1909 /******************************************************************************
1911 * Protocol for calling a generic fumction
1912 * This protocol is roughly equivalent to (parameter are a little bit different
1913 * for efficiency reasons):
1915 * + apply-generic (gf args)
1916 * + compute-applicable-methods (gf args ...)
1917 * + sort-applicable-methods (methods args)
1918 * + apply-methods (gf methods args)
1920 * apply-methods calls make-next-method to build the "continuation" of a a
1921 * method. Applying a next-method will call apply-next-method which in
1922 * turn will call apply again to call effectively the following method.
1924 ******************************************************************************/
1927 applicablep (SCM actual
, SCM formal
)
1929 /* We already know that the cpl is well formed. */
1930 return scm_is_true (scm_c_memq (formal
, SCM_SLOT (actual
, scm_si_cpl
)));
1934 more_specificp (SCM m1
, SCM m2
, SCM
const *targs
)
1936 register SCM s1
, s2
;
1940 * m1 and m2 can have != length (i.e. one can be one element longer than the
1941 * other when we have a dotted parameter list). For instance, with the call
1944 * (define-method M (a . l) ....)
1945 * (define-method M (a) ....)
1947 * we consider that the second method is more specific.
1949 * BTW, targs is an array of types. We don't need it's size since
1950 * we already know that m1 and m2 are applicable (no risk to go past
1951 * the end of this array).
1954 for (i
=0, s1
=SPEC_OF(m1
), s2
=SPEC_OF(m2
); ; i
++, s1
=SCM_CDR(s1
), s2
=SCM_CDR(s2
)) {
1955 if (scm_is_null(s1
)) return 1;
1956 if (scm_is_null(s2
)) return 0;
1957 if (SCM_CAR(s1
) != SCM_CAR(s2
)) {
1958 register SCM l
, cs1
= SCM_CAR(s1
), cs2
= SCM_CAR(s2
);
1960 for (l
= SCM_SLOT (targs
[i
], scm_si_cpl
); ; l
= SCM_CDR(l
)) {
1961 if (cs1
== SCM_CAR(l
))
1963 if (cs2
== SCM_CAR(l
))
1966 return 0;/* should not occur! */
1969 return 0; /* should not occur! */
1972 #define BUFFSIZE 32 /* big enough for most uses */
1975 scm_i_vector2list (SCM l
, long len
)
1978 SCM z
= scm_c_make_vector (len
, SCM_UNDEFINED
);
1980 for (j
= 0; j
< len
; j
++, l
= SCM_CDR (l
)) {
1981 SCM_SIMPLE_VECTOR_SET (z
, j
, SCM_CAR (l
));
1987 sort_applicable_methods (SCM method_list
, long size
, SCM
const *targs
)
1990 SCM
*v
, vector
= SCM_EOL
;
1991 SCM buffer
[BUFFSIZE
];
1992 SCM save
= method_list
;
1993 scm_t_array_handle handle
;
1995 /* For reasonably sized method_lists we can try to avoid all the
1996 * consing and reorder the list in place...
1997 * This idea is due to David McClain <Dave_McClain@msn.com>
1999 if (size
<= BUFFSIZE
)
2001 for (i
= 0; i
< size
; i
++)
2003 buffer
[i
] = SCM_CAR (method_list
);
2004 method_list
= SCM_CDR (method_list
);
2010 /* Too many elements in method_list to keep everything locally */
2011 vector
= scm_i_vector2list (save
, size
);
2012 v
= scm_vector_writable_elements (vector
, &handle
, NULL
, NULL
);
2015 /* Use a simple shell sort since it is generally faster than qsort on
2016 * small vectors (which is probably mostly the case when we have to
2017 * sort a list of applicable methods).
2019 for (incr
= size
/ 2; incr
; incr
/= 2)
2021 for (i
= incr
; i
< size
; i
++)
2023 for (j
= i
- incr
; j
>= 0; j
-= incr
)
2025 if (more_specificp (v
[j
], v
[j
+incr
], targs
))
2029 SCM tmp
= v
[j
+ incr
];
2037 if (size
<= BUFFSIZE
)
2039 /* We did it in locally, so restore the original list (reordered) in-place */
2040 for (i
= 0, method_list
= save
; i
< size
; i
++, v
++)
2042 SCM_SETCAR (method_list
, *v
);
2043 method_list
= SCM_CDR (method_list
);
2048 /* If we are here, that's that we did it the hard way... */
2049 scm_array_handle_release (&handle
);
2050 return scm_vector_to_list (vector
);
2054 scm_compute_applicable_methods (SCM gf
, SCM args
, long len
, int find_method_p
)
2058 SCM l
, fl
, applicable
= SCM_EOL
;
2060 SCM buffer
[BUFFSIZE
];
2064 scm_t_array_handle handle
;
2066 /* Build the list of arguments types */
2067 if (len
>= BUFFSIZE
)
2069 tmp
= scm_c_make_vector (len
, SCM_UNDEFINED
);
2070 types
= p
= scm_vector_writable_elements (tmp
, &handle
, NULL
, NULL
);
2073 note that we don't have to work to reset the generation
2074 count. TMP is a new vector anyway, and it is found
2081 for ( ; !scm_is_null (args
); args
= SCM_CDR (args
))
2082 *p
++ = scm_class_of (SCM_CAR (args
));
2084 /* Build a list of all applicable methods */
2085 for (l
= scm_generic_function_methods (gf
); !scm_is_null (l
); l
= SCM_CDR (l
))
2087 fl
= SPEC_OF (SCM_CAR (l
));
2088 /* Only accept accessors which match exactly in first arg. */
2089 if (SCM_ACCESSORP (SCM_CAR (l
))
2090 && (scm_is_null (fl
) || types
[0] != SCM_CAR (fl
)))
2092 for (i
= 0; ; i
++, fl
= SCM_CDR (fl
))
2094 if (SCM_INSTANCEP (fl
)
2095 /* We have a dotted argument list */
2096 || (i
>= len
&& scm_is_null (fl
)))
2097 { /* both list exhausted */
2098 applicable
= scm_cons (SCM_CAR (l
), applicable
);
2104 || !applicablep (types
[i
], SCM_CAR (fl
)))
2109 if (len
>= BUFFSIZE
)
2110 scm_array_handle_release (&handle
);
2116 CALL_GF2 ("no-applicable-method", gf
, save
);
2117 /* if we are here, it's because no-applicable-method hasn't signaled an error */
2123 : sort_applicable_methods (applicable
, count
, types
));
2127 SCM_PROC (s_sys_compute_applicable_methods
, "%compute-applicable-methods", 2, 0, 0, scm_sys_compute_applicable_methods
);
2130 static const char s_sys_compute_applicable_methods
[] = "%compute-applicable-methods";
2133 scm_sys_compute_applicable_methods (SCM gf
, SCM args
)
2134 #define FUNC_NAME s_sys_compute_applicable_methods
2137 SCM_VALIDATE_GENERIC (1, gf
);
2138 n
= scm_ilength (args
);
2139 SCM_ASSERT (n
>= 0, args
, SCM_ARG2
, FUNC_NAME
);
2140 return scm_compute_applicable_methods (gf
, args
, n
, 1);
2144 SCM_SYMBOL (sym_compute_applicable_methods
, "compute-applicable-methods");
2145 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
));
2148 lock_cache_mutex (void *m
)
2150 SCM mutex
= SCM_PACK ((scm_t_bits
) m
);
2151 scm_lock_mutex (mutex
);
2155 unlock_cache_mutex (void *m
)
2157 SCM mutex
= SCM_PACK ((scm_t_bits
) m
);
2158 scm_unlock_mutex (mutex
);
2162 call_memoize_method (void *a
)
2164 SCM args
= SCM_PACK ((scm_t_bits
) a
);
2165 SCM gf
= SCM_CAR (args
);
2166 SCM x
= SCM_CADR (args
);
2167 /* First check if another thread has inserted a method between
2168 * the cache miss and locking the mutex.
2170 SCM cmethod
= scm_mcache_lookup_cmethod (x
, SCM_CDDR (args
));
2171 if (scm_is_true (cmethod
))
2173 /*fixme* Use scm_apply */
2174 return CALL_GF3 ("memoize-method!", gf
, SCM_CDDR (args
), x
);
2178 scm_memoize_method (SCM x
, SCM args
)
2180 SCM gf
= SCM_CAR (scm_last_pair (x
));
2181 return scm_internal_dynamic_wind (
2183 call_memoize_method
,
2185 (void *) SCM_UNPACK (scm_cons2 (gf
, x
, args
)),
2186 (void *) SCM_UNPACK (SCM_SLOT (gf
, scm_si_cache_mutex
)));
2189 /******************************************************************************
2191 * A simple make (which will be redefined later in Scheme)
2192 * This version handles only creation of gf, methods and classes (no instances)
2194 * Since this code will disappear when Goops will be fully booted,
2195 * no precaution is taken to be efficient.
2197 ******************************************************************************/
2199 SCM_KEYWORD (k_setter
, "setter");
2200 SCM_KEYWORD (k_specializers
, "specializers");
2201 SCM_KEYWORD (k_procedure
, "procedure");
2202 SCM_KEYWORD (k_dsupers
, "dsupers");
2203 SCM_KEYWORD (k_slots
, "slots");
2204 SCM_KEYWORD (k_gf
, "generic-function");
2206 SCM_DEFINE (scm_make
, "make", 0, 0, 1,
2208 "Make a new object. @var{args} must contain the class and\n"
2209 "all necessary initialization information.")
2210 #define FUNC_NAME s_scm_make
2213 long len
= scm_ilength (args
);
2215 if (len
<= 0 || (len
& 1) == 0)
2216 SCM_WRONG_NUM_ARGS ();
2218 class = SCM_CAR(args
);
2219 args
= SCM_CDR(args
);
2221 if (class == scm_class_generic
|| class == scm_class_accessor
)
2223 z
= scm_make_struct (class, SCM_INUM0
,
2224 scm_list_5 (SCM_EOL
,
2229 scm_set_procedure_property_x (z
, scm_sym_name
,
2230 scm_get_keyword (k_name
,
2233 clear_method_cache (z
);
2234 if (class == scm_class_accessor
)
2236 SCM setter
= scm_get_keyword (k_setter
, args
, SCM_BOOL_F
);
2237 if (scm_is_true (setter
))
2238 scm_sys_set_object_setter_x (z
, setter
);
2243 z
= scm_sys_allocate_instance (class, args
);
2245 if (class == scm_class_method
2246 || class == scm_class_simple_method
2247 || class == scm_class_accessor_method
)
2249 SCM_SET_SLOT (z
, scm_si_generic_function
,
2250 scm_i_get_keyword (k_gf
,
2255 SCM_SET_SLOT (z
, scm_si_specializers
,
2256 scm_i_get_keyword (k_specializers
,
2261 SCM_SET_SLOT (z
, scm_si_procedure
,
2262 scm_i_get_keyword (k_procedure
,
2267 SCM_SET_SLOT (z
, scm_si_code_table
, SCM_EOL
);
2271 /* In all the others case, make a new class .... No instance here */
2272 SCM_SET_SLOT (z
, scm_si_name
,
2273 scm_i_get_keyword (k_name
,
2276 scm_from_locale_symbol ("???"),
2278 SCM_SET_SLOT (z
, scm_si_direct_supers
,
2279 scm_i_get_keyword (k_dsupers
,
2284 SCM_SET_SLOT (z
, scm_si_direct_slots
,
2285 scm_i_get_keyword (k_slots
,
2296 SCM_DEFINE (scm_find_method
, "find-method", 0, 0, 1,
2299 #define FUNC_NAME s_scm_find_method
2302 long len
= scm_ilength (l
);
2305 SCM_WRONG_NUM_ARGS ();
2307 gf
= SCM_CAR(l
); l
= SCM_CDR(l
);
2308 SCM_VALIDATE_GENERIC (1, gf
);
2309 if (scm_is_null (SCM_SLOT (gf
, scm_si_methods
)))
2310 SCM_MISC_ERROR ("no methods for generic ~S", scm_list_1 (gf
));
2312 return scm_compute_applicable_methods (gf
, l
, len
- 1, 1);
2316 SCM_DEFINE (scm_sys_method_more_specific_p
, "%method-more-specific?", 3, 0, 0,
2317 (SCM m1
, SCM m2
, SCM targs
),
2319 #define FUNC_NAME s_scm_sys_method_more_specific_p
2324 scm_t_array_handle handle
;
2326 SCM_VALIDATE_METHOD (1, m1
);
2327 SCM_VALIDATE_METHOD (2, m2
);
2328 SCM_ASSERT ((len
= scm_ilength (targs
)) != -1, targs
, SCM_ARG3
, FUNC_NAME
);
2330 /* Verify that all the arguments of targs are classes and place them
2334 v
= scm_c_make_vector (len
, SCM_EOL
);
2335 v_elts
= scm_vector_writable_elements (v
, &handle
, NULL
, NULL
);
2337 for (i
= 0, l
= targs
; i
< len
&& scm_is_pair (l
); i
++, l
= SCM_CDR (l
))
2339 SCM_ASSERT (SCM_CLASSP (SCM_CAR (l
)), targs
, SCM_ARG3
, FUNC_NAME
);
2340 v_elts
[i
] = SCM_CAR(l
);
2342 result
= more_specificp (m1
, m2
, v_elts
) ? SCM_BOOL_T
: SCM_BOOL_F
;
2344 scm_array_handle_release (&handle
);
2352 /******************************************************************************
2356 ******************************************************************************/
2359 fix_cpl (SCM c
, SCM before
, SCM after
)
2361 SCM cpl
= SCM_SLOT (c
, scm_si_cpl
);
2362 SCM ls
= scm_c_memq (after
, cpl
);
2363 SCM tail
= scm_delq1_x (before
, SCM_CDR (ls
));
2364 if (scm_is_false (ls
))
2365 /* if this condition occurs, fix_cpl should not be applied this way */
2367 SCM_SETCAR (ls
, before
);
2368 SCM_SETCDR (ls
, scm_cons (after
, tail
));
2370 SCM dslots
= SCM_SLOT (c
, scm_si_direct_slots
);
2371 SCM slots
= build_slots_list (maplist (dslots
), cpl
);
2372 SCM g_n_s
= compute_getters_n_setters (slots
);
2373 SCM_SET_SLOT (c
, scm_si_slots
, slots
);
2374 SCM_SET_SLOT (c
, scm_si_getters_n_setters
, g_n_s
);
2380 make_stdcls (SCM
*var
, char *name
, SCM meta
, SCM super
, SCM slots
)
2382 SCM tmp
= scm_from_locale_symbol (name
);
2384 *var
= scm_permanent_object (scm_basic_make_class (meta
,
2388 : scm_list_1 (super
),
2394 SCM_KEYWORD (k_slot_definition
, "slot-definition");
2397 create_standard_classes (void)
2400 SCM method_slots
= scm_list_4 (scm_from_locale_symbol ("generic-function"),
2401 scm_from_locale_symbol ("specializers"),
2403 scm_from_locale_symbol ("code-table"));
2404 SCM amethod_slots
= scm_list_1 (scm_list_3 (scm_from_locale_symbol ("slot-definition"),
2406 k_slot_definition
));
2407 SCM mutex_slot
= scm_list_1 (scm_from_locale_symbol ("make-mutex"));
2408 SCM mutex_closure
= scm_i_eval_x (scm_list_3 (scm_sym_lambda
,
2412 SCM gf_slots
= scm_list_5 (scm_from_locale_symbol ("methods"),
2413 scm_list_3 (scm_from_locale_symbol ("n-specialized"),
2416 scm_list_3 (scm_from_locale_symbol ("used-by"),
2419 scm_list_3 (scm_from_locale_symbol ("cache-mutex"),
2422 scm_list_3 (scm_from_locale_symbol ("extended-by"),
2425 SCM egf_slots
= scm_list_1 (scm_list_3 (scm_from_locale_symbol ("extends"),
2428 /* Foreign class slot classes */
2429 make_stdcls (&scm_class_foreign_slot
, "<foreign-slot>",
2430 scm_class_class
, scm_class_top
, SCM_EOL
);
2431 make_stdcls (&scm_class_protected
, "<protected-slot>",
2432 scm_class_class
, scm_class_foreign_slot
, SCM_EOL
);
2433 make_stdcls (&scm_class_opaque
, "<opaque-slot>",
2434 scm_class_class
, scm_class_foreign_slot
, SCM_EOL
);
2435 make_stdcls (&scm_class_read_only
, "<read-only-slot>",
2436 scm_class_class
, scm_class_foreign_slot
, SCM_EOL
);
2437 make_stdcls (&scm_class_self
, "<self-slot>",
2439 scm_class_read_only
,
2441 make_stdcls (&scm_class_protected_opaque
, "<protected-opaque-slot>",
2443 scm_list_2 (scm_class_protected
, scm_class_opaque
),
2445 make_stdcls (&scm_class_protected_read_only
, "<protected-read-only-slot>",
2447 scm_list_2 (scm_class_protected
, scm_class_read_only
),
2449 make_stdcls (&scm_class_scm
, "<scm-slot>",
2450 scm_class_class
, scm_class_protected
, SCM_EOL
);
2451 make_stdcls (&scm_class_int
, "<int-slot>",
2452 scm_class_class
, scm_class_foreign_slot
, SCM_EOL
);
2453 make_stdcls (&scm_class_float
, "<float-slot>",
2454 scm_class_class
, scm_class_foreign_slot
, SCM_EOL
);
2455 make_stdcls (&scm_class_double
, "<double-slot>",
2456 scm_class_class
, scm_class_foreign_slot
, SCM_EOL
);
2458 /* Continue initialization of class <class> */
2460 slots
= build_class_class_slots ();
2461 SCM_SET_SLOT (scm_class_class
, scm_si_direct_slots
, slots
);
2462 SCM_SET_SLOT (scm_class_class
, scm_si_slots
, slots
);
2463 SCM_SET_SLOT (scm_class_class
, scm_si_getters_n_setters
,
2464 compute_getters_n_setters (slots
));
2466 make_stdcls (&scm_class_foreign_class
, "<foreign-class>",
2467 scm_class_class
, scm_class_class
,
2468 scm_list_2 (scm_list_3 (scm_from_locale_symbol ("constructor"),
2471 scm_list_3 (scm_from_locale_symbol ("destructor"),
2473 scm_class_opaque
)));
2474 make_stdcls (&scm_class_foreign_object
, "<foreign-object>",
2475 scm_class_foreign_class
, scm_class_object
, SCM_EOL
);
2476 SCM_SET_CLASS_FLAGS (scm_class_foreign_object
, SCM_CLASSF_FOREIGN
);
2478 /* scm_class_generic functions classes */
2479 make_stdcls (&scm_class_procedure_class
, "<procedure-class>",
2480 scm_class_class
, scm_class_class
, SCM_EOL
);
2481 make_stdcls (&scm_class_entity_class
, "<entity-class>",
2482 scm_class_class
, scm_class_procedure_class
, SCM_EOL
);
2483 make_stdcls (&scm_class_operator_class
, "<operator-class>",
2484 scm_class_class
, scm_class_procedure_class
, SCM_EOL
);
2485 make_stdcls (&scm_class_operator_with_setter_class
,
2486 "<operator-with-setter-class>",
2487 scm_class_class
, scm_class_operator_class
, SCM_EOL
);
2488 make_stdcls (&scm_class_method
, "<method>",
2489 scm_class_class
, scm_class_object
, method_slots
);
2490 make_stdcls (&scm_class_simple_method
, "<simple-method>",
2491 scm_class_class
, scm_class_method
, SCM_EOL
);
2492 SCM_SET_CLASS_FLAGS (scm_class_simple_method
, SCM_CLASSF_SIMPLE_METHOD
);
2493 make_stdcls (&scm_class_accessor_method
, "<accessor-method>",
2494 scm_class_class
, scm_class_simple_method
, amethod_slots
);
2495 SCM_SET_CLASS_FLAGS (scm_class_accessor_method
, SCM_CLASSF_ACCESSOR_METHOD
);
2496 make_stdcls (&scm_class_applicable
, "<applicable>",
2497 scm_class_class
, scm_class_top
, SCM_EOL
);
2498 make_stdcls (&scm_class_entity
, "<entity>",
2499 scm_class_entity_class
,
2500 scm_list_2 (scm_class_object
, scm_class_applicable
),
2502 make_stdcls (&scm_class_entity_with_setter
, "<entity-with-setter>",
2503 scm_class_entity_class
, scm_class_entity
, SCM_EOL
);
2504 make_stdcls (&scm_class_generic
, "<generic>",
2505 scm_class_entity_class
, scm_class_entity
, gf_slots
);
2506 SCM_SET_CLASS_FLAGS (scm_class_generic
, SCM_CLASSF_PURE_GENERIC
);
2507 make_stdcls (&scm_class_extended_generic
, "<extended-generic>",
2508 scm_class_entity_class
, scm_class_generic
, egf_slots
);
2509 SCM_SET_CLASS_FLAGS (scm_class_extended_generic
, SCM_CLASSF_PURE_GENERIC
);
2510 make_stdcls (&scm_class_generic_with_setter
, "<generic-with-setter>",
2511 scm_class_entity_class
,
2512 scm_list_2 (scm_class_generic
, scm_class_entity_with_setter
),
2514 SCM_SET_CLASS_FLAGS (scm_class_generic_with_setter
, SCM_CLASSF_PURE_GENERIC
);
2515 make_stdcls (&scm_class_accessor
, "<accessor>",
2516 scm_class_entity_class
, scm_class_generic_with_setter
, SCM_EOL
);
2517 SCM_SET_CLASS_FLAGS (scm_class_accessor
, SCM_CLASSF_PURE_GENERIC
);
2518 make_stdcls (&scm_class_extended_generic_with_setter
,
2519 "<extended-generic-with-setter>",
2520 scm_class_entity_class
,
2521 scm_list_2 (scm_class_generic_with_setter
,
2522 scm_class_extended_generic
),
2524 SCM_SET_CLASS_FLAGS (scm_class_extended_generic_with_setter
,
2525 SCM_CLASSF_PURE_GENERIC
);
2526 make_stdcls (&scm_class_extended_accessor
, "<extended-accessor>",
2527 scm_class_entity_class
,
2528 scm_list_2 (scm_class_accessor
,
2529 scm_class_extended_generic_with_setter
),
2531 fix_cpl (scm_class_extended_accessor
,
2532 scm_class_extended_generic
, scm_class_generic
);
2533 SCM_SET_CLASS_FLAGS (scm_class_extended_accessor
, SCM_CLASSF_PURE_GENERIC
);
2535 /* Primitive types classes */
2536 make_stdcls (&scm_class_boolean
, "<boolean>",
2537 scm_class_class
, scm_class_top
, SCM_EOL
);
2538 make_stdcls (&scm_class_char
, "<char>",
2539 scm_class_class
, scm_class_top
, SCM_EOL
);
2540 make_stdcls (&scm_class_list
, "<list>",
2541 scm_class_class
, scm_class_top
, SCM_EOL
);
2542 make_stdcls (&scm_class_pair
, "<pair>",
2543 scm_class_class
, scm_class_list
, SCM_EOL
);
2544 make_stdcls (&scm_class_null
, "<null>",
2545 scm_class_class
, scm_class_list
, SCM_EOL
);
2546 make_stdcls (&scm_class_string
, "<string>",
2547 scm_class_class
, scm_class_top
, SCM_EOL
);
2548 make_stdcls (&scm_class_symbol
, "<symbol>",
2549 scm_class_class
, scm_class_top
, SCM_EOL
);
2550 make_stdcls (&scm_class_vector
, "<vector>",
2551 scm_class_class
, scm_class_top
, SCM_EOL
);
2552 make_stdcls (&scm_class_number
, "<number>",
2553 scm_class_class
, scm_class_top
, SCM_EOL
);
2554 make_stdcls (&scm_class_complex
, "<complex>",
2555 scm_class_class
, scm_class_number
, SCM_EOL
);
2556 make_stdcls (&scm_class_real
, "<real>",
2557 scm_class_class
, scm_class_complex
, SCM_EOL
);
2558 make_stdcls (&scm_class_integer
, "<integer>",
2559 scm_class_class
, scm_class_real
, SCM_EOL
);
2560 make_stdcls (&scm_class_fraction
, "<fraction>",
2561 scm_class_class
, scm_class_real
, SCM_EOL
);
2562 make_stdcls (&scm_class_keyword
, "<keyword>",
2563 scm_class_class
, scm_class_top
, SCM_EOL
);
2564 make_stdcls (&scm_class_unknown
, "<unknown>",
2565 scm_class_class
, scm_class_top
, SCM_EOL
);
2566 make_stdcls (&scm_class_procedure
, "<procedure>",
2567 scm_class_procedure_class
, scm_class_applicable
, SCM_EOL
);
2568 make_stdcls (&scm_class_procedure_with_setter
, "<procedure-with-setter>",
2569 scm_class_procedure_class
, scm_class_procedure
, SCM_EOL
);
2570 make_stdcls (&scm_class_primitive_generic
, "<primitive-generic>",
2571 scm_class_procedure_class
, scm_class_procedure
, SCM_EOL
);
2572 make_stdcls (&scm_class_port
, "<port>",
2573 scm_class_class
, scm_class_top
, SCM_EOL
);
2574 make_stdcls (&scm_class_input_port
, "<input-port>",
2575 scm_class_class
, scm_class_port
, SCM_EOL
);
2576 make_stdcls (&scm_class_output_port
, "<output-port>",
2577 scm_class_class
, scm_class_port
, SCM_EOL
);
2578 make_stdcls (&scm_class_input_output_port
, "<input-output-port>",
2580 scm_list_2 (scm_class_input_port
, scm_class_output_port
),
2584 /**********************************************************************
2588 **********************************************************************/
2591 make_class_from_template (char const *template, char const *type_name
, SCM supers
, int applicablep
)
2597 sprintf (buffer
, template, type_name
);
2598 name
= scm_from_locale_symbol (buffer
);
2601 name
= SCM_GOOPS_UNBOUND
;
2603 class = scm_permanent_object (scm_basic_make_class (applicablep
2604 ? scm_class_procedure_class
2610 /* Only define name if doesn't already exist. */
2611 if (!SCM_GOOPS_UNBOUNDP (name
)
2612 && scm_is_false (scm_call_2 (scm_goops_lookup_closure
, name
, SCM_BOOL_F
)))
2613 DEFVAR (name
, class);
2618 scm_make_extended_class (char const *type_name
, int applicablep
)
2620 return make_class_from_template ("<%s>",
2622 scm_list_1 (applicablep
2623 ? scm_class_applicable
2629 scm_i_inherit_applicable (SCM c
)
2631 if (!SCM_SUBCLASSP (c
, scm_class_applicable
))
2633 SCM dsupers
= SCM_SLOT (c
, scm_si_direct_supers
);
2634 SCM cpl
= SCM_SLOT (c
, scm_si_cpl
);
2635 /* patch scm_class_applicable into direct-supers */
2636 SCM top
= scm_c_memq (scm_class_top
, dsupers
);
2637 if (scm_is_false (top
))
2638 dsupers
= scm_append (scm_list_2 (dsupers
,
2639 scm_list_1 (scm_class_applicable
)));
2642 SCM_SETCAR (top
, scm_class_applicable
);
2643 SCM_SETCDR (top
, scm_cons (scm_class_top
, SCM_CDR (top
)));
2645 SCM_SET_SLOT (c
, scm_si_direct_supers
, dsupers
);
2646 /* patch scm_class_applicable into cpl */
2647 top
= scm_c_memq (scm_class_top
, cpl
);
2648 if (scm_is_false (top
))
2652 SCM_SETCAR (top
, scm_class_applicable
);
2653 SCM_SETCDR (top
, scm_cons (scm_class_top
, SCM_CDR (top
)));
2655 /* add class to direct-subclasses of scm_class_applicable */
2656 SCM_SET_SLOT (scm_class_applicable
,
2657 scm_si_direct_subclasses
,
2658 scm_cons (c
, SCM_SLOT (scm_class_applicable
,
2659 scm_si_direct_subclasses
)));
2664 create_smob_classes (void)
2668 scm_smob_class
= (SCM
*) scm_malloc (255 * sizeof (SCM
));
2669 for (i
= 0; i
< 255; ++i
)
2670 scm_smob_class
[i
] = 0;
2672 scm_smob_class
[SCM_TC2SMOBNUM (scm_tc16_keyword
)] = scm_class_keyword
;
2674 for (i
= 0; i
< scm_numsmob
; ++i
)
2675 if (!scm_smob_class
[i
])
2676 scm_smob_class
[i
] = scm_make_extended_class (SCM_SMOBNAME (i
),
2677 scm_smobs
[i
].apply
!= 0);
2681 scm_make_port_classes (long ptobnum
, char *type_name
)
2683 SCM c
, class = make_class_from_template ("<%s-port>",
2685 scm_list_1 (scm_class_port
),
2687 scm_port_class
[SCM_IN_PCLASS_INDEX
+ ptobnum
]
2688 = make_class_from_template ("<%s-input-port>",
2690 scm_list_2 (class, scm_class_input_port
),
2692 scm_port_class
[SCM_OUT_PCLASS_INDEX
+ ptobnum
]
2693 = make_class_from_template ("<%s-output-port>",
2695 scm_list_2 (class, scm_class_output_port
),
2697 scm_port_class
[SCM_INOUT_PCLASS_INDEX
+ ptobnum
]
2699 = make_class_from_template ("<%s-input-output-port>",
2701 scm_list_2 (class, scm_class_input_output_port
),
2703 /* Patch cpl (since this tree is too complex for the C level compute-cpl) */
2704 SCM_SET_SLOT (c
, scm_si_cpl
,
2705 scm_cons2 (c
, class, SCM_SLOT (scm_class_input_output_port
, scm_si_cpl
)));
2709 create_port_classes (void)
2713 scm_port_class
= (SCM
*) scm_malloc (3 * 256 * sizeof (SCM
));
2714 for (i
= 0; i
< 3 * 256; ++i
)
2715 scm_port_class
[i
] = 0;
2717 for (i
= 0; i
< scm_numptob
; ++i
)
2718 scm_make_port_classes (i
, SCM_PTOBNAME (i
));
2722 make_struct_class (void *closure SCM_UNUSED
,
2723 SCM vtable
, SCM data
, SCM prev SCM_UNUSED
)
2725 if (scm_is_true (SCM_STRUCT_TABLE_NAME (data
)))
2726 SCM_SET_STRUCT_TABLE_CLASS (data
,
2727 scm_make_extended_class
2728 (scm_i_symbol_chars (SCM_STRUCT_TABLE_NAME (data
)),
2729 SCM_CLASS_FLAGS (vtable
) & SCM_CLASSF_OPERATOR
));
2730 return SCM_UNSPECIFIED
;
2734 create_struct_classes (void)
2736 scm_internal_hash_fold (make_struct_class
, 0, SCM_BOOL_F
, scm_struct_table
);
2739 /**********************************************************************
2743 **********************************************************************/
2748 if (!goops_loaded_p
)
2749 scm_c_resolve_module ("oop goops");
2754 scm_make_foreign_object (SCM
class, SCM initargs
)
2755 #define FUNC_NAME s_scm_make
2757 void * (*constructor
) (SCM
)
2758 = (void * (*) (SCM
)) SCM_SLOT (class, scm_si_constructor
);
2759 if (constructor
== 0)
2760 SCM_MISC_ERROR ("Can't make instances of class ~S", scm_list_1 (class));
2761 return scm_wrap_object (class, constructor (initargs
));
2767 scm_free_foreign_object (SCM
*class, SCM
*data
)
2769 size_t (*destructor
) (void *)
2770 = (size_t (*) (void *)) class[scm_si_destructor
];
2771 return destructor (data
);
2775 scm_make_class (SCM meta
, char *s_name
, SCM supers
, size_t size
,
2776 void * (*constructor
) (SCM initargs
),
2777 size_t (*destructor
) (void *))
2780 name
= scm_from_locale_symbol (s_name
);
2781 if (scm_is_null (supers
))
2782 supers
= scm_list_1 (scm_class_foreign_object
);
2783 class = scm_basic_basic_make_class (meta
, name
, supers
, SCM_EOL
);
2784 scm_sys_inherit_magic_x (class, supers
);
2786 if (destructor
!= 0)
2788 SCM_SET_SLOT (class, scm_si_destructor
, (SCM
) destructor
);
2789 SCM_SET_CLASS_DESTRUCTOR (class, scm_free_foreign_object
);
2793 SCM_SET_CLASS_DESTRUCTOR (class, scm_struct_free_light
);
2794 SCM_SET_CLASS_INSTANCE_SIZE (class, size
);
2797 SCM_SET_SLOT (class, scm_si_layout
, scm_from_locale_symbol (""));
2798 SCM_SET_SLOT (class, scm_si_constructor
, (SCM
) constructor
);
2803 SCM_SYMBOL (sym_o
, "o");
2804 SCM_SYMBOL (sym_x
, "x");
2806 SCM_KEYWORD (k_accessor
, "accessor");
2807 SCM_KEYWORD (k_getter
, "getter");
2810 default_setter (SCM obj SCM_UNUSED
, SCM c SCM_UNUSED
)
2812 scm_misc_error ("slot-set!", "read-only slot", SCM_EOL
);
2817 scm_add_slot (SCM
class, char *slot_name
, SCM slot_class
,
2818 SCM (*getter
) (SCM obj
),
2819 SCM (*setter
) (SCM obj
, SCM x
),
2820 char *accessor_name
)
2823 SCM get
= scm_c_make_subr ("goops:get", scm_tc7_subr_1
, getter
);
2824 SCM set
= scm_c_make_subr ("goops:set", scm_tc7_subr_2
,
2825 setter
? setter
: default_setter
);
2827 /* Dirk:FIXME:: The following two expressions make use of the fact that
2828 * the memoizer will accept a subr-object in the place of a function.
2829 * This is not guaranteed to stay this way. */
2830 SCM getm
= scm_i_eval_x (scm_list_3 (scm_sym_lambda
,
2832 scm_list_2 (get
, sym_o
)),
2834 SCM setm
= scm_i_eval_x (scm_list_3 (scm_sym_lambda
,
2835 scm_list_2 (sym_o
, sym_x
),
2836 scm_list_3 (set
, sym_o
, sym_x
)),
2840 SCM name
= scm_from_locale_symbol (slot_name
);
2841 SCM aname
= scm_from_locale_symbol (accessor_name
);
2842 SCM gf
= scm_ensure_accessor (aname
);
2843 SCM slot
= scm_list_5 (name
,
2846 setter
? k_accessor
: k_getter
,
2848 scm_add_method (gf
, scm_make (scm_list_5 (scm_class_accessor_method
,
2853 scm_add_method (scm_setter (gf
),
2854 scm_make (scm_list_5 (scm_class_accessor_method
,
2856 scm_list_2 (class, scm_class_top
),
2861 SCM_SET_SLOT (class, scm_si_slots
,
2862 scm_append_x (scm_list_2 (SCM_SLOT (class, scm_si_slots
),
2863 scm_list_1 (slot
))));
2865 SCM n
= SCM_SLOT (class, scm_si_nfields
);
2866 SCM gns
= scm_list_n (name
, SCM_BOOL_F
, get
, set
, n
, scm_from_int (1));
2867 SCM_SET_SLOT (class, scm_si_getters_n_setters
,
2868 scm_append_x (scm_list_2 (SCM_SLOT (class, scm_si_getters_n_setters
),
2869 scm_list_1 (gns
))));
2870 SCM_SET_SLOT (class, scm_si_nfields
, scm_sum (n
, scm_from_int (1)));
2877 scm_wrap_object (SCM
class, void *data
)
2879 return scm_double_cell (SCM_UNPACK (SCM_CDR (class)) | scm_tc3_struct
,
2887 scm_wrap_component (SCM
class, SCM container
, void *data
)
2889 SCM obj
= scm_wrap_object (class, data
);
2890 SCM handle
= scm_hash_fn_create_handle_x (scm_components
,
2896 SCM_SETCDR (handle
, container
);
2901 scm_ensure_accessor (SCM name
)
2903 SCM gf
= scm_call_2 (SCM_TOP_LEVEL_LOOKUP_CLOSURE
, name
, SCM_BOOL_F
);
2904 if (!SCM_IS_A_P (gf
, scm_class_accessor
))
2906 gf
= scm_make (scm_list_3 (scm_class_generic
, k_name
, name
));
2907 gf
= scm_make (scm_list_5 (scm_class_accessor
,
2908 k_name
, name
, k_setter
, gf
));
2913 SCM_SYMBOL (sym_internal_add_method_x
, "internal-add-method!");
2916 scm_add_method (SCM gf
, SCM m
)
2918 scm_eval (scm_list_3 (sym_internal_add_method_x
, gf
, m
), scm_module_goops
);
2923 * Debugging utilities
2926 SCM_DEFINE (scm_pure_generic_p
, "pure-generic?", 1, 0, 0,
2928 "Return @code{#t} if @var{obj} is a pure generic.")
2929 #define FUNC_NAME s_scm_pure_generic_p
2931 return scm_from_bool (SCM_PUREGENERICP (obj
));
2935 #endif /* GUILE_DEBUG */
2941 SCM_DEFINE (scm_sys_goops_loaded
, "%goops-loaded", 0, 0, 0,
2943 "Announce that GOOPS is loaded and perform initialization\n"
2944 "on the C level which depends on the loaded GOOPS modules.")
2945 #define FUNC_NAME s_scm_sys_goops_loaded
2948 var_compute_applicable_methods
=
2949 scm_sym2var (sym_compute_applicable_methods
, scm_goops_lookup_closure
,
2951 setup_extended_primitive_generics ();
2952 return SCM_UNSPECIFIED
;
2956 SCM scm_module_goops
;
2959 scm_init_goops_builtins (void)
2961 scm_module_goops
= scm_current_module ();
2962 scm_goops_lookup_closure
= scm_module_lookup_closure (scm_module_goops
);
2964 /* Not really necessary right now, but who knows...
2966 scm_permanent_object (scm_module_goops
);
2967 scm_permanent_object (scm_goops_lookup_closure
);
2969 scm_components
= scm_permanent_object (scm_make_weak_key_hash_table
2970 (scm_from_int (37)));
2972 goops_rstate
= scm_c_make_rstate ("GOOPS", 5);
2974 #include "libguile/goops.x"
2976 list_of_no_method
= scm_permanent_object (scm_list_1 (sym_no_method
));
2978 hell
= scm_malloc (hell_size
);
2979 hell_mutex
= scm_permanent_object (scm_make_mutex ());
2981 create_basic_classes ();
2982 create_standard_classes ();
2983 create_smob_classes ();
2984 create_struct_classes ();
2985 create_port_classes ();
2988 SCM name
= scm_from_locale_symbol ("no-applicable-method");
2989 scm_no_applicable_method
2990 = scm_permanent_object (scm_make (scm_list_3 (scm_class_generic
,
2993 DEFVAR (name
, scm_no_applicable_method
);
2996 return SCM_UNSPECIFIED
;
3002 scm_c_define_gsubr ("%init-goops-builtins", 0, 0, 0,
3003 scm_init_goops_builtins
);