1 /* Copyright (C) 1998, 1999, 2000 Free Software Foundation, Inc.
3 * This program is free software; you can redistribute it and/or modify
4 * it under the terms of the GNU General Public License as published by
5 * the Free Software Foundation; either version 2, or (at your option)
8 * This program is distributed in the hope that it will be useful,
9 * but WITHOUT ANY WARRANTY; without even the implied warranty of
10 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
11 * GNU General Public License for more details.
13 * You should have received a copy of the GNU General Public License
14 * along with this software; see the file COPYING. If not, write to
15 * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
16 * Boston, MA 02111-1307 USA
18 * As a special exception, the Free Software Foundation gives permission
19 * for additional uses of the text contained in its release of GUILE.
21 * The exception is that, if you link the GUILE library with other files
22 * to produce an executable, this does not by itself cause the
23 * resulting executable to be covered by the GNU General Public License.
24 * Your use of that executable is in no way restricted on account of
25 * linking the GUILE library code into it.
27 * This exception does not however invalidate any other reasons why
28 * the executable file might be covered by the GNU General Public License.
30 * This exception applies only to the code released by the
31 * Free Software Foundation under the name GUILE. If you copy
32 * code from other Free Software Foundation releases into a copy of
33 * GUILE, as the General Public License permits, the exception does
34 * not apply to the code that you add in this way. To avoid misleading
35 * anyone as to the status of such modified files, you must delete
36 * this exception notice from them.
38 * If you write modifications of your own for GUILE, it is your choice
39 * whether to permit this exception to apply to your modifications.
40 * If you do not wish that, delete this exception notice. */
43 /* This software is a derivative work of other copyrighted softwares; the
44 * copyright notices of these softwares are placed in the file COPYRIGHTS
46 * This file is based upon stklos.c from the STk distribution by
47 * Erick Gallesio <eg@unice.fr>.
52 #include "libguile/_scm.h"
53 #include "libguile/alist.h"
54 #include "libguile/debug.h"
55 #include "libguile/dynl.h"
56 #include "libguile/dynwind.h"
57 #include "libguile/eval.h"
58 #include "libguile/hashtab.h"
59 #include "libguile/keywords.h"
60 #include "libguile/macros.h"
61 #include "libguile/modules.h"
62 #include "libguile/objects.h"
63 #include "libguile/ports.h"
64 #include "libguile/procprop.h"
65 #include "libguile/random.h"
66 #include "libguile/smob.h"
67 #include "libguile/strings.h"
68 #include "libguile/strports.h"
69 #include "libguile/vectors.h"
70 #include "libguile/weaks.h"
72 #include "libguile/goops.h"
74 #define CLASSP(x) (SCM_STRUCTP (x) \
75 && SCM_OBJ_CLASS_FLAGS (x) & SCM_CLASSF_METACLASS)
76 #define GENERICP(x) (SCM_INSTANCEP (x) \
77 && SCM_SUBCLASSP (SCM_CLASS_OF (x), scm_class_generic))
78 #define METHODP(x) (SCM_INSTANCEP (x) \
79 && SCM_SUBCLASSP(SCM_CLASS_OF(x), scm_class_method))
80 #define SPEC_OF(x) SCM_SLOT (x, scm_si_specializers)
83 #define DEFVAR(v,val) \
84 { scm_eval2 (SCM_LIST3 (scm_sym_define_public, (v), (val)), \
85 scm_goops_lookup_closure); }
86 /* Temporary hack until we get the new module system */
87 /*fixme* Should optimize by keeping track of the variable object itself */
88 #define GETVAR(v) (SCM_CDDR (scm_apply (scm_goops_lookup_closure, \
89 SCM_LIST2 ((v), SCM_BOOL_F), \
92 Intern (const char *s
)
94 return SCM_CAR (scm_intern (s
, strlen (s
)));
97 /* Fixme: Should use already interned symbols */
98 #define CALL_GF1(name,a) (scm_apply (GETVAR (Intern(name)), \
99 SCM_LIST1 (a), SCM_EOL))
100 #define CALL_GF2(name,a,b) (scm_apply (GETVAR (Intern(name)), \
101 SCM_LIST2 (a, b), SCM_EOL))
102 #define CALL_GF3(name,a,b,c) (scm_apply (GETVAR (Intern(name)), \
103 SCM_LIST3 (a, b, c), SCM_EOL))
104 #define CALL_GF4(name,a,b,c,d) (scm_apply (GETVAR (Intern(name)), \
105 SCM_LIST4 (a, b, c, d), SCM_EOL))
107 /* Class redefinition protocol:
109 A class is represented by a heap header h1 which points to a
110 malloc:ed memory block m1.
112 When a new version of a class is created, a new header h2 and
113 memory block m2 are allocated. The headers h1 and h2 then switch
114 pointers so that h1 refers to m2 and h2 to m1. In this way, names
115 bound to h1 will point to the new class at the same time as h2 will
116 be a handle which the GC will us to free m1.
118 The `redefined' slot of m1 will be set to point to h1. An old
119 instance will have it's class pointer (the CAR of the heap header)
120 pointing to m1. The non-immediate `redefined'-slot in m1 indicates
121 the class modification and the new class pointer can be found via
125 #define SCM_CLASS_REDEF(c) SCM_SLOT (c, scm_si_redefined)
126 /* The following definition is located in libguile/objects.h:
127 #define SCM_OBJ_CLASS_REDEF(x) (SCM_STRUCT_VTABLE_DATA(x)[scm_si_redefined])
130 #define TEST_CHANGE_CLASS(obj, class) \
132 class = SCM_CLASS_OF (obj); \
133 if (SCM_OBJ_CLASS_REDEF (obj) != SCM_BOOL_F) \
134 CALL_GF3 ("change-object-class", \
135 obj, class, SCM_OBJ_CLASS_REDEF (obj)); \
138 #define NXT_MTHD_METHODS(m) (SCM_VELTS (m)[1])
139 #define NXT_MTHD_ARGS(m) (SCM_VELTS (m)[2])
141 #define SCM_GOOPS_UNBOUND SCM_UNBOUND
142 #define SCM_GOOPS_UNBOUNDP(x) ((x) == SCM_GOOPS_UNBOUND)
144 static int goops_loaded_p
= 0;
145 static scm_rstate
*goops_rstate
;
147 static SCM scm_goops_lookup_closure
;
149 /* Some classes are defined in libguile/objects.c. */
150 SCM scm_class_top
, scm_class_object
, scm_class_class
;
151 SCM scm_class_entity
, scm_class_entity_with_setter
;
152 SCM scm_class_generic
, scm_class_generic_with_setter
, scm_class_method
;
153 SCM scm_class_simple_method
, scm_class_accessor
;
154 SCM scm_class_procedure_class
;
155 SCM scm_class_operator_class
, scm_class_operator_with_setter_class
;
156 SCM scm_class_entity_class
;
157 SCM scm_class_number
, scm_class_list
;
158 SCM scm_class_keyword
;
159 SCM scm_class_port
, scm_class_input_output_port
;
160 SCM scm_class_input_port
, scm_class_output_port
;
161 SCM scm_class_foreign_class
, scm_class_foreign_object
;
162 SCM scm_class_foreign_slot
;
163 SCM scm_class_self
, scm_class_protected
;
164 SCM scm_class_opaque
, scm_class_read_only
;
165 SCM scm_class_protected_opaque
, scm_class_protected_read_only
;
167 SCM scm_class_int
, scm_class_float
, scm_class_double
;
169 SCM_SYMBOL (scm_sym_define_public
, "define-public");
171 static SCM
scm_make_unbound (void);
172 static SCM
scm_unbound_p (SCM obj
);
174 /******************************************************************************
178 * This version doesn't handle multiple-inheritance. It serves only for
179 * booting classes and will be overaloaded in Scheme
181 ******************************************************************************/
185 compute_cpl (SCM supers
, SCM res
)
187 return (SCM_NULLP (supers
)
189 : compute_cpl (SCM_SLOT (SCM_CAR (supers
), scm_si_direct_supers
),
190 scm_cons (SCM_CAR (supers
), res
)));
195 map (SCM (*proc
) (SCM
), SCM ls
)
200 SCM res
= scm_cons (proc (SCM_CAR (ls
)), SCM_EOL
);
203 while (SCM_NIMP (ls
))
205 SCM_SETCDR (h
, scm_cons (proc (SCM_CAR (ls
)), SCM_EOL
));
217 while (SCM_NIMP (ls
))
219 SCM el
= SCM_CAR (ls
);
220 if (SCM_IMP (scm_sloppy_memq (el
, res
)))
221 res
= scm_cons (el
, res
);
228 compute_cpl (SCM
class)
231 return CALL_GF1 ("compute-cpl", class);
234 SCM supers
= SCM_SLOT (class, scm_si_direct_supers
);
235 SCM ls
= scm_append (scm_acons (class, supers
,
236 map (compute_cpl
, supers
)));
237 return scm_reverse_x (filter_cpl (ls
), SCM_EOL
);
241 /******************************************************************************
245 ******************************************************************************/
248 remove_duplicate_slots (SCM l
, SCM res
, SCM slots_already_seen
)
256 if (!(SCM_NIMP (tmp
) && SCM_SYMBOLP (tmp
)))
257 scm_misc_error ("%compute-slots",
261 if (SCM_NULLP (scm_sloppy_memq (tmp
, slots_already_seen
))) {
262 res
= scm_cons (SCM_CAR (l
), res
);
263 slots_already_seen
= scm_cons (tmp
, slots_already_seen
);
266 return remove_duplicate_slots (SCM_CDR (l
), res
, slots_already_seen
);
270 build_slots_list (SCM dslots
, SCM cpl
)
272 register SCM res
= dslots
;
274 for (cpl
= SCM_CDR(cpl
); SCM_NNULLP(cpl
); cpl
= SCM_CDR(cpl
))
275 res
= scm_append (SCM_LIST2 (SCM_SLOT (SCM_CAR (cpl
), scm_si_direct_slots
),
278 /* res contains a list of slots. Remove slots which appears more than once */
279 return remove_duplicate_slots (scm_reverse (res
), SCM_EOL
, SCM_EOL
);
286 while (SCM_NIMP (ls
))
288 if (!(SCM_NIMP (SCM_CAR (ls
)) && SCM_CONSP (SCM_CAR (ls
))))
289 SCM_SETCAR (ls
, scm_cons (SCM_CAR (ls
), SCM_EOL
));
295 SCM_PROC (s_sys_compute_slots
, "%compute-slots", 1, 0, 0, scm_sys_compute_slots
);
298 scm_sys_compute_slots (SCM
class)
300 SCM_ASSERT (SCM_NIMP (class) && CLASSP (class),
301 class, SCM_ARG1
, s_sys_compute_slots
);
302 return build_slots_list (SCM_SLOT (class, scm_si_direct_slots
),
303 SCM_SLOT (class, scm_si_cpl
));
306 /******************************************************************************
308 * compute-getters-n-setters
310 * This version doesn't handle slot options. It serves only for booting
311 * classes and will be overaloaded in Scheme.
313 ******************************************************************************/
315 SCM_KEYWORD (k_init_value
, "init-value");
316 SCM_KEYWORD (k_init_thunk
, "init-thunk");
319 compute_getters_n_setters (SCM slots
)
325 for ( ; SCM_NNULLP(slots
); slots
= SCM_CDR(slots
))
327 SCM init
= SCM_BOOL_F
;
328 SCM options
= SCM_CDAR (slots
);
329 if (SCM_NNULLP (options
))
331 init
= scm_get_keyword (k_init_value
, options
, 0);
333 init
= scm_closure (SCM_LIST2 (SCM_EOL
, init
), SCM_EOL
);
335 init
= scm_get_keyword (k_init_thunk
, options
, SCM_BOOL_F
);
337 *cdrloc
= scm_cons (scm_cons (SCM_CAAR (slots
),
341 cdrloc
= SCM_CDRLOC (*cdrloc
);
346 /******************************************************************************
350 ******************************************************************************/
352 /*fixme* Manufacture keywords in advance */
354 scm_i_get_keyword (SCM key
, SCM l
, int len
, SCM default_value
, const char *subr
)
357 for (i
= 0; i
< len
; i
+= 2)
359 if (!(SCM_NIMP (SCM_CAR (l
)) && SCM_KEYWORDP (SCM_CAR (l
))))
360 scm_misc_error (subr
,
362 SCM_LIST1 (SCM_CAR (l
)));
363 if (SCM_CAR (l
) == key
)
367 return default_value
;
370 SCM_PROC (s_get_keyword
, "get-keyword", 3, 0, 0, scm_get_keyword
);
373 scm_get_keyword (SCM key
, SCM l
, SCM default_value
)
376 SCM_ASSERT (SCM_NIMP (key
) && SCM_KEYWORDP (key
),
380 len
= scm_ilength (l
);
381 SCM_ASSERT (len
>= 0 && (len
& 1) == 0, l
,
382 "Bad keyword-value list: ~S",
384 return scm_i_get_keyword (key
, l
, len
, default_value
, s_get_keyword
);
387 SCM_PROC (s_sys_initialize_object
, "%initialize-object", 2, 0, 0, scm_sys_initialize_object
);
389 SCM_KEYWORD (k_init_keyword
, "init-keyword");
391 static SCM
get_slot_value (SCM
class, SCM obj
, SCM slotdef
);
392 static SCM
set_slot_value (SCM
class, SCM obj
, SCM slotdef
, SCM value
);
395 scm_sys_initialize_object (SCM obj
, SCM initargs
)
397 SCM tmp
, get_n_set
, slots
;
398 SCM
class = SCM_CLASS_OF (obj
);
401 SCM_ASSERT (SCM_NIMP (obj
) && SCM_INSTANCEP (obj
),
402 obj
, SCM_ARG1
, s_sys_initialize_object
);
403 n_initargs
= scm_ilength (initargs
);
404 SCM_ASSERT ((n_initargs
& 1) == 0,
405 initargs
, SCM_ARG2
, s_sys_initialize_object
);
407 get_n_set
= SCM_SLOT (class, scm_si_getters_n_setters
);
408 slots
= SCM_SLOT (class, scm_si_slots
);
410 /* See for each slot how it must be initialized */
413 get_n_set
= SCM_CDR (get_n_set
), slots
= SCM_CDR (slots
))
415 SCM slot_name
= SCM_CAR (slots
);
418 if (SCM_NIMP (SCM_CDR (slot_name
)))
420 /* This slot admits (perhaps) to be initialized at creation time */
421 int n
= scm_ilength (SCM_CDR (slot_name
));
422 if (n
& 1) /* odd or -1 */
423 scm_misc_error (s_sys_initialize_object
,
424 "class contains bogus slot definition: ~S",
425 SCM_LIST1 (slot_name
));
426 tmp
= scm_i_get_keyword (k_init_keyword
,
430 s_sys_initialize_object
);
431 slot_name
= SCM_CAR (slot_name
);
434 /* an initarg was provided for this slot */
435 if (!(SCM_NIMP (tmp
) && SCM_KEYWORDP (tmp
)))
436 scm_misc_error (s_sys_initialize_object
,
437 "initarg must be a keyword. It was ~S",
439 slot_value
= scm_i_get_keyword (tmp
,
443 s_sys_initialize_object
);
448 /* set slot to provided value */
449 set_slot_value (class, obj
, SCM_CAR (get_n_set
), slot_value
);
452 /* set slot to its :init-form if it exists */
453 tmp
= SCM_CADAR (get_n_set
);
454 if (tmp
!= SCM_BOOL_F
)
456 slot_value
= get_slot_value (class, obj
, SCM_CAR (get_n_set
));
457 if (SCM_GOOPS_UNBOUNDP (slot_value
))
459 SCM env
= SCM_EXTEND_ENV (SCM_EOL
, SCM_EOL
, SCM_ENV (tmp
));
460 set_slot_value (class,
463 scm_eval_body (SCM_CDR (SCM_CODE (tmp
)),
474 SCM_KEYWORD (k_class
, "class");
476 SCM_PROC (s_sys_prep_layout_x
, "%prep-layout!", 1, 0, 0, scm_sys_prep_layout_x
);
479 scm_sys_prep_layout_x (SCM
class)
483 SCM nfields
, slots
, type
;
485 SCM_ASSERT (SCM_NIMP (class) && SCM_INSTANCEP (class),
488 s_sys_prep_layout_x
);
489 slots
= SCM_SLOT (class, scm_si_slots
);
490 nfields
= SCM_SLOT (class, scm_si_nfields
);
491 if (!SCM_INUMP (nfields
) || SCM_INUM (nfields
) < 0)
492 scm_misc_error (s_sys_prep_layout_x
,
493 "bad value in nfields slot: ~S",
494 SCM_LIST1 (nfields
));
495 n
= 2 * SCM_INUM (nfields
);
496 if (n
< sizeof (SCM_CLASS_CLASS_LAYOUT
) - 1
497 && SCM_SUBCLASSP (class, scm_class_class
))
498 scm_misc_error (s_sys_prep_layout_x
,
499 "class object doesn't have enough fields: ~S",
500 SCM_LIST1 (nfields
));
502 s
= n
> 0 ? scm_must_malloc (n
, s_sys_prep_layout_x
) : 0;
503 for (i
= 0; i
< n
; i
+= 2)
505 if (!(SCM_NIMP (slots
) && SCM_CONSP (slots
)))
506 scm_misc_error (s_sys_prep_layout_x
,
507 "to few slot definitions",
509 len
= scm_ilength (SCM_CDAR (slots
));
510 type
= scm_i_get_keyword (k_class
, SCM_CDAR (slots
), len
, SCM_BOOL_F
,
511 s_sys_prep_layout_x
);
512 if (SCM_NIMP (type
) && SCM_SUBCLASSP (type
, scm_class_foreign_slot
))
514 if (SCM_SUBCLASSP (type
, scm_class_self
))
516 else if (SCM_SUBCLASSP (type
, scm_class_protected
))
521 if (SCM_SUBCLASSP (type
, scm_class_opaque
))
523 else if (SCM_SUBCLASSP (type
, scm_class_read_only
))
535 slots
= SCM_CDR (slots
);
537 SCM_SLOT (class, scm_si_layout
) = SCM_CAR (scm_intern (s
, n
));
540 return SCM_UNSPECIFIED
;
543 static void prep_hashsets (SCM
);
545 SCM_PROC (s_sys_inherit_magic_x
, "%inherit-magic!", 2, 0, 0, scm_sys_inherit_magic_x
);
548 scm_sys_inherit_magic_x (SCM
class, SCM dsupers
)
552 SCM_ASSERT (SCM_NIMP (class) && SCM_INSTANCEP (class),
555 s_sys_inherit_magic_x
);
556 while (SCM_NNULLP (ls
))
558 SCM_ASSERT (SCM_NIMP (ls
)
560 && SCM_NIMP (SCM_CAR (ls
))
561 && SCM_INSTANCEP (SCM_CAR (ls
)),
564 s_sys_inherit_magic_x
);
565 flags
|= SCM_CLASS_FLAGS (SCM_CAR (ls
));
568 flags
&= SCM_CLASSF_INHERIT
;
569 if (flags
& SCM_CLASSF_ENTITY
)
570 SCM_SET_CLASS_DESTRUCTOR (class, scm_struct_free_entity
);
573 int n
= SCM_INUM (SCM_SLOT (class, scm_si_nfields
));
576 * We could avoid calling scm_must_malloc in the allocation code
577 * (in which case the following two lines are needed). Instead
578 * we make 0-slot instances non-light, so that the light case
579 * can be handled without special cases.
582 SCM_SET_CLASS_DESTRUCTOR (class, scm_struct_free_0
);
584 if (n
> 0 && !(flags
& SCM_CLASSF_METACLASS
))
586 /* NOTE: The following depends on scm_struct_i_size. */
587 flags
|= SCM_STRUCTF_LIGHT
+ n
* sizeof (SCM
); /* use light representation */
588 SCM_SET_CLASS_DESTRUCTOR (class, scm_struct_free_light
);
591 SCM_SET_CLASS_FLAGS (class, flags
);
593 prep_hashsets (class);
595 return SCM_UNSPECIFIED
;
599 prep_hashsets (SCM
class)
603 for (i
= 0; i
< 7; ++i
)
604 SCM_SLOT (class, scm_si_hashsets
+ i
)
605 = SCM_PACK (scm_c_uniform32 (goops_rstate
));
608 /******************************************************************************/
611 scm_basic_basic_make_class (SCM
class, SCM name
, SCM dsupers
, SCM dslots
)
613 SCM z
, cpl
, slots
, nfields
, g_n_s
;
615 /* Allocate one instance */
616 z
= scm_make_struct (class, SCM_INUM0
, SCM_EOL
);
618 /* Initialize its slots */
620 cpl
= compute_cpl (dsupers
, SCM_LIST1(z
));
622 SCM_SLOT (z
, scm_si_direct_supers
) = dsupers
;
623 cpl
= compute_cpl (z
);
624 slots
= build_slots_list (maplist (dslots
), cpl
);
625 nfields
= SCM_MAKINUM (scm_ilength (slots
));
626 g_n_s
= compute_getters_n_setters (slots
);
628 SCM_SLOT(z
, scm_si_name
) = name
;
629 SCM_SLOT(z
, scm_si_direct_slots
) = dslots
;
630 SCM_SLOT(z
, scm_si_direct_subclasses
) = SCM_EOL
;
631 SCM_SLOT(z
, scm_si_direct_methods
) = SCM_EOL
;
632 SCM_SLOT(z
, scm_si_cpl
) = cpl
;
633 SCM_SLOT(z
, scm_si_slots
) = slots
;
634 SCM_SLOT(z
, scm_si_nfields
) = nfields
;
635 SCM_SLOT(z
, scm_si_getters_n_setters
) = g_n_s
;
636 SCM_SLOT(z
, scm_si_redefined
) = SCM_BOOL_F
;
637 SCM_SLOT(z
, scm_si_environment
)
638 = scm_top_level_env (SCM_TOP_LEVEL_LOOKUP_CLOSURE
);
640 /* Add this class in the direct-subclasses slot of dsupers */
643 for (tmp
= dsupers
; SCM_NNULLP(tmp
); tmp
= SCM_CDR(tmp
))
644 SCM_SLOT(SCM_CAR(tmp
), scm_si_direct_subclasses
)
645 = scm_cons(z
, SCM_SLOT(SCM_CAR(tmp
), scm_si_direct_subclasses
));
648 /* Support for the underlying structs: */
649 SCM_SET_CLASS_FLAGS (z
, (class == scm_class_entity_class
650 ? (SCM_CLASSF_GOOPS_OR_VALID
651 | SCM_CLASSF_OPERATOR
653 : class == scm_class_operator_class
654 ? SCM_CLASSF_GOOPS_OR_VALID
| SCM_CLASSF_OPERATOR
655 : SCM_CLASSF_GOOPS_OR_VALID
));
660 scm_basic_make_class (SCM
class, SCM name
, SCM dsupers
, SCM dslots
)
662 SCM z
= scm_basic_basic_make_class (class, name
, dsupers
, dslots
);
663 scm_sys_inherit_magic_x (z
, dsupers
);
664 scm_sys_prep_layout_x (z
);
668 /******************************************************************************/
671 build_class_class_slots ()
674 scm_cons (SCM_LIST3 (Intern ("layout"),
676 scm_class_protected_read_only
),
677 scm_cons (SCM_LIST3 (Intern ("vcell"),
680 scm_cons (SCM_LIST3 (Intern ("vtable"),
683 scm_cons (Intern ("print"),
684 scm_cons (SCM_LIST3 (Intern ("procedure"),
686 scm_class_protected_opaque
),
687 scm_cons (SCM_LIST3 (Intern ("setter"),
689 scm_class_protected_opaque
),
690 scm_cons (Intern ("redefined"),
691 scm_cons (SCM_LIST3 (Intern ("h0"),
694 scm_cons (SCM_LIST3 (Intern ("h1"),
697 scm_cons (SCM_LIST3 (Intern ("h2"),
700 scm_cons (SCM_LIST3 (Intern ("h3"),
703 scm_cons (SCM_LIST3 (Intern ("h4"),
706 scm_cons (SCM_LIST3 (Intern ("h5"),
709 scm_cons (SCM_LIST3 (Intern ("h6"),
712 scm_cons (SCM_LIST3 (Intern ("h7"),
715 scm_cons (Intern ("name"),
716 scm_cons (Intern ("direct-supers"),
717 scm_cons (Intern ("direct-slots"),
718 scm_cons (Intern ("direct-subclasses"),
719 scm_cons (Intern ("direct-methods"),
720 scm_cons (Intern ("cpl"),
721 scm_cons (Intern ("default-slot-definition-class"),
722 scm_cons (Intern ("slots"),
723 scm_cons (Intern ("getters-n-setters"), /* name-access */
724 scm_cons (Intern ("keyword-access"),
725 scm_cons (Intern ("nfields"),
726 scm_cons (Intern ("environment"),
727 SCM_EOL
))))))))))))))))))))))))))));
731 create_basic_classes (void)
733 /* SCM slots_of_class = build_class_class_slots (); */
735 /**** <scm_class_class> ****/
736 SCM cs
= scm_makfrom0str (SCM_CLASS_CLASS_LAYOUT
737 + 2 * scm_vtable_offset_user
);
738 SCM name
= Intern ("<class>");
739 scm_class_class
= scm_permanent_object (scm_make_vtable_vtable (cs
,
742 SCM_SET_CLASS_FLAGS (scm_class_class
, (SCM_CLASSF_GOOPS_OR_VALID
743 | SCM_CLASSF_METACLASS
));
745 SCM_SLOT(scm_class_class
, scm_si_name
) = name
;
746 SCM_SLOT(scm_class_class
, scm_si_direct_supers
) = SCM_EOL
; /* will be changed */
747 /* SCM_SLOT(scm_class_class, scm_si_direct_slots) = slots_of_class; */
748 SCM_SLOT(scm_class_class
, scm_si_direct_subclasses
)= SCM_EOL
;
749 SCM_SLOT(scm_class_class
, scm_si_direct_methods
) = SCM_EOL
;
750 SCM_SLOT(scm_class_class
, scm_si_cpl
) = SCM_EOL
; /* will be changed */
751 /* SCM_SLOT(scm_class_class, scm_si_slots) = slots_of_class; */
752 SCM_SLOT(scm_class_class
, scm_si_nfields
) = SCM_MAKINUM (SCM_N_CLASS_SLOTS
);
753 /* SCM_SLOT(scm_class_class, scm_si_getters_n_setters)
754 = compute_getters_n_setters (slots_of_class); */
755 SCM_SLOT(scm_class_class
, scm_si_redefined
) = SCM_BOOL_F
;
756 SCM_SLOT(scm_class_class
, scm_si_environment
)
757 = scm_top_level_env (SCM_TOP_LEVEL_LOOKUP_CLOSURE
);
759 prep_hashsets (scm_class_class
);
761 DEFVAR(name
, scm_class_class
);
763 /**** <scm_class_top> ****/
764 name
= Intern ("<top>");
765 scm_class_top
= scm_permanent_object (scm_basic_make_class (scm_class_class
,
770 DEFVAR(name
, scm_class_top
);
772 /**** <scm_class_object> ****/
773 name
= Intern("<object>");
774 scm_class_object
= scm_permanent_object (scm_basic_make_class (scm_class_class
,
776 SCM_LIST1 (scm_class_top
),
779 DEFVAR (name
, scm_class_object
);
781 /* <top> <object> and <class> were partially initialized. Correct them here */
782 SCM_SLOT (scm_class_object
, scm_si_direct_subclasses
) = SCM_LIST1 (scm_class_class
);
784 SCM_SLOT (scm_class_class
, scm_si_direct_supers
) = SCM_LIST1 (scm_class_object
);
785 SCM_SLOT (scm_class_class
, scm_si_cpl
) = SCM_LIST3 (scm_class_class
, scm_class_object
, scm_class_top
);
788 /******************************************************************************/
790 SCM_PROC (s_instance_p
, "instance?", 1, 0, 0, scm_instance_p
);
793 scm_instance_p (SCM obj
)
795 return SCM_NIMP (obj
) && SCM_INSTANCEP (obj
) ? SCM_BOOL_T
: SCM_BOOL_F
;
798 SCM_PROC (s_class_of
, "class-of", 1, 0, 0, scm_class_of
);
799 /* scm_class_of is defined in libguile */
801 /******************************************************************************
803 * Meta object accessors
805 ******************************************************************************/
806 SCM_PROC (s_class_name
, "class-name", 1, 0, 0, scm_class_name
);
809 scm_class_name (SCM obj
)
811 SCM_ASSERT (SCM_NIMP (obj
) && CLASSP (obj
), obj
, SCM_ARG1
, s_class_name
);
812 return scm_slot_ref (obj
, Intern ("name"));
815 SCM_PROC (s_class_direct_supers
, "class-direct-supers", 1, 0, 0, scm_class_direct_supers
);
818 scm_class_direct_supers (SCM obj
)
820 SCM_ASSERT (SCM_NIMP (obj
) && CLASSP (obj
), obj
, SCM_ARG1
, s_class_direct_supers
);
821 return scm_slot_ref (obj
, Intern("direct-supers"));
824 SCM_PROC (s_class_direct_slots
, "class-direct-slots", 1, 0, 0, scm_class_direct_slots
);
827 scm_class_direct_slots (SCM obj
)
829 SCM_ASSERT (SCM_NIMP (obj
) && CLASSP (obj
),
830 obj
, SCM_ARG1
, s_class_direct_slots
);
831 return scm_slot_ref (obj
, Intern ("direct-slots"));
834 SCM_PROC (s_class_direct_subclasses
, "class-direct-subclasses", 1, 0, 0, scm_class_direct_subclasses
);
837 scm_class_direct_subclasses (SCM obj
)
839 SCM_ASSERT (SCM_NIMP (obj
) && CLASSP (obj
),
840 obj
, SCM_ARG1
, s_class_direct_subclasses
);
841 return scm_slot_ref(obj
, Intern ("direct-subclasses"));
844 SCM_PROC (s_class_direct_methods
, "class-direct-methods", 1, 0, 0, scm_class_direct_methods
);
847 scm_class_direct_methods (SCM obj
)
849 SCM_ASSERT (SCM_NIMP (obj
) && CLASSP (obj
),
850 obj
, SCM_ARG1
, s_class_direct_methods
);
851 return scm_slot_ref (obj
, Intern("direct-methods"));
854 SCM_PROC (s_class_direct_precedence_list
, "class-precedence-list", 1, 0, 0, scm_class_precedence_list
);
857 scm_class_precedence_list (SCM obj
)
859 SCM_ASSERT (SCM_NIMP (obj
) && CLASSP (obj
),
860 obj
, SCM_ARG1
, s_class_direct_precedence_list
);
861 return scm_slot_ref (obj
, Intern ("cpl"));
864 SCM_PROC (s_class_slots
, "class-slots", 1, 0, 0, scm_class_slots
);
867 scm_class_slots (SCM obj
)
869 SCM_ASSERT (SCM_NIMP (obj
) && CLASSP (obj
),
870 obj
, SCM_ARG1
, s_class_slots
);
871 return scm_slot_ref (obj
, Intern ("slots"));
874 SCM_PROC (s_class_environment
, "class-environment", 1, 0, 0, scm_class_environment
);
877 scm_class_environment (SCM obj
)
879 SCM_ASSERT (SCM_NIMP (obj
) && CLASSP (obj
),
880 obj
, SCM_ARG1
, s_class_environment
);
881 return scm_slot_ref(obj
, Intern ("environment"));
885 SCM_PROC (s_generic_function_name
, "generic-function-name", 1, 0, 0, scm_generic_function_name
);
888 scm_generic_function_name (SCM obj
)
890 SCM_ASSERT (SCM_NIMP (obj
) && GENERICP (obj
),
891 obj
, SCM_ARG1
, s_generic_function_name
);
892 return scm_procedure_property (obj
, scm_sym_name
);
895 SCM_PROC (s_generic_function_methods
, "generic-function-methods", 1, 0, 0, scm_generic_function_methods
);
898 scm_generic_function_methods (SCM obj
)
900 SCM_ASSERT (SCM_NIMP (obj
) && GENERICP (obj
),
901 obj
, SCM_ARG1
, s_generic_function_methods
);
902 return scm_slot_ref (obj
, Intern ("methods"));
906 SCM_PROC (s_method_generic_function
, "method-generic-function", 1, 0, 0, scm_method_generic_function
);
909 scm_method_generic_function (SCM obj
)
911 SCM_ASSERT (SCM_NIMP (obj
) && METHODP (obj
),
912 obj
, SCM_ARG1
, s_method_generic_function
);
913 return scm_slot_ref (obj
, Intern ("generic-function"));
916 SCM_PROC (s_method_specializers
, "method-specializers", 1, 0, 0, scm_method_specializers
);
919 scm_method_specializers (SCM obj
)
921 SCM_ASSERT (SCM_NIMP (obj
) && METHODP (obj
),
922 obj
, SCM_ARG1
, s_method_specializers
);
923 return scm_slot_ref (obj
, Intern ("specializers"));
926 SCM_PROC (s_method_procedure
, "method-procedure", 1, 0, 0, scm_method_procedure
);
929 scm_method_procedure (SCM obj
)
931 SCM_ASSERT (SCM_NIMP (obj
) && METHODP (obj
),
932 obj
, SCM_ARG1
, s_method_procedure
);
933 return scm_slot_ref (obj
, Intern ("procedure"));
936 SCM_PROC (s_accessor_method_slot_definition
, "accessor-method-slot-definition", 1, 0, 0, scm_accessor_method_slot_definition
);
939 scm_accessor_method_slot_definition (SCM obj
)
941 SCM_ASSERT (SCM_NIMP (obj
) && SCM_ACCESSORP (obj
),
942 obj
, SCM_ARG1
, s_method_procedure
);
943 return scm_slot_ref (obj
, Intern ("slot-definition"));
947 /******************************************************************************
949 * S l o t a c c e s s
951 ******************************************************************************/
953 SCM_PROC (s_make_unbound
, "make-unbound", 0, 0, 0, scm_make_unbound
);
958 return SCM_GOOPS_UNBOUND
;
961 SCM_PROC (s_unbound_p
, "unbound?", 1, 0, 0, scm_unbound_p
);
964 scm_unbound_p (SCM obj
)
966 return SCM_GOOPS_UNBOUNDP (obj
) ? SCM_BOOL_T
: SCM_BOOL_F
;
969 SCM_PROC (s_assert_bound
, "assert-bound", 2, 0, 0, scm_assert_bound
);
972 scm_assert_bound (SCM value
, SCM obj
)
974 if (SCM_GOOPS_UNBOUNDP (value
))
975 return CALL_GF1 ("slot-unbound", obj
);
979 SCM_PROC (s_at_assert_bound_ref
, "@assert-bound-ref", 2, 0, 0, scm_at_assert_bound_ref
);
982 scm_at_assert_bound_ref (SCM obj
, SCM index
)
984 SCM value
= SCM_SLOT (obj
, SCM_INUM (index
));
985 if (SCM_GOOPS_UNBOUNDP (value
))
986 return CALL_GF1 ("slot-unbound", obj
);
990 SCM_PROC (s_sys_fast_slot_ref
, "%fast-slot-ref", 2, 0, 0, scm_sys_fast_slot_ref
);
993 scm_sys_fast_slot_ref (SCM obj
, SCM index
)
997 SCM_ASSERT (SCM_NIMP (obj
) && SCM_INSTANCEP (obj
),
998 obj
, SCM_ARG1
, s_sys_fast_slot_ref
);
999 SCM_ASSERT (SCM_INUMP (index
), index
, SCM_ARG2
, s_sys_fast_slot_ref
);
1000 i
= SCM_INUM (index
);
1001 SCM_ASSERT (i
>= 0 && i
< SCM_NUMBER_OF_SLOTS (obj
),
1002 index
, SCM_OUTOFRANGE
, s_sys_fast_slot_ref
);
1003 return scm_at_assert_bound_ref (obj
, index
);
1006 SCM_PROC (s_sys_fast_slot_set_x
, "%fast-slot-set!", 3, 0, 0, scm_sys_fast_slot_set_x
);
1009 scm_sys_fast_slot_set_x (SCM obj
, SCM index
, SCM value
)
1013 SCM_ASSERT (SCM_NIMP (obj
) && SCM_INSTANCEP (obj
),
1014 obj
, SCM_ARG1
, s_sys_fast_slot_set_x
);
1015 SCM_ASSERT (SCM_INUMP (index
), index
, SCM_ARG2
, s_sys_fast_slot_set_x
);
1016 i
= SCM_INUM (index
);
1017 SCM_ASSERT (i
>= 0 && i
< SCM_NUMBER_OF_SLOTS (obj
),
1018 index
, SCM_OUTOFRANGE
, s_sys_fast_slot_set_x
);
1020 SCM_SLOT (obj
, i
) = value
;
1021 return SCM_UNSPECIFIED
;
1026 /* In the future, this function will return the effective slot
1027 * definition associated with SLOT_NAME. Now it just returns some of
1028 * the information which will be stored in the effective slot
1033 slot_definition_using_name (SCM
class, SCM slot_name
)
1035 register SCM slots
= SCM_SLOT (class, scm_si_getters_n_setters
);
1036 for (; SCM_NIMP (slots
); slots
= SCM_CDR (slots
))
1037 if (SCM_CAAR (slots
) == slot_name
)
1038 return SCM_CAR (slots
);
1043 get_slot_value (SCM
class, SCM obj
, SCM slotdef
)
1045 SCM access
= SCM_CDDR (slotdef
);
1047 * - access is an integer (the offset of this slot in the slots vector)
1048 * - otherwise (car access) is the getter function to apply
1050 if (SCM_INUMP (access
))
1051 return SCM_SLOT (obj
, SCM_INUM (access
));
1054 /* We must evaluate (apply (car access) (list obj))
1055 * where (car access) is known to be a closure of arity 1 */
1056 register SCM code
, env
;
1058 code
= SCM_CAR (access
);
1059 if (!SCM_CLOSUREP (code
))
1060 return SCM_SUBRF (code
) (obj
);
1061 env
= SCM_EXTEND_ENV (SCM_CAR (SCM_CODE (code
)),
1064 /* Evaluate the closure body */
1065 return scm_eval_body (SCM_CDR (SCM_CODE (code
)), env
);
1070 get_slot_value_using_name (SCM
class, SCM obj
, SCM slot_name
)
1072 SCM slotdef
= slot_definition_using_name (class, slot_name
);
1073 if (SCM_NFALSEP (slotdef
))
1074 return get_slot_value (class, obj
, slotdef
);
1076 return CALL_GF3 ("slot-missing", class, obj
, slot_name
);
1080 set_slot_value (SCM
class, SCM obj
, SCM slotdef
, SCM value
)
1082 SCM access
= SCM_CDDR (slotdef
);
1084 * - access is an integer (the offset of this slot in the slots vector)
1085 * - otherwise (cadr access) is the setter function to apply
1087 if (SCM_INUMP (access
))
1088 SCM_SLOT (obj
, SCM_INUM (access
)) = value
;
1091 /* We must evaluate (apply (cadr l) (list obj value))
1092 * where (cadr l) is known to be a closure of arity 2 */
1093 register SCM code
, env
;
1095 code
= SCM_CADR (access
);
1096 if (!SCM_CLOSUREP (code
))
1097 SCM_SUBRF (code
) (obj
, value
);
1100 env
= SCM_EXTEND_ENV (SCM_CAR (SCM_CODE (code
)),
1101 SCM_LIST2 (obj
, value
),
1103 /* Evaluate the closure body */
1104 scm_eval_body (SCM_CDR (SCM_CODE (code
)), env
);
1107 return SCM_UNSPECIFIED
;
1111 set_slot_value_using_name (SCM
class, SCM obj
, SCM slot_name
, SCM value
)
1113 SCM slotdef
= slot_definition_using_name (class, slot_name
);
1114 if (SCM_NFALSEP (slotdef
))
1115 return set_slot_value (class, obj
, slotdef
, value
);
1117 return CALL_GF4 ("slot-missing", class, obj
, slot_name
, value
);
1121 test_slot_existence (SCM
class, SCM obj
, SCM slot_name
)
1125 for (l
= SCM_ACCESSORS_OF (obj
); SCM_NNULLP (l
); l
= SCM_CDR (l
))
1126 if (SCM_CAAR (l
) == slot_name
)
1132 /* The current libguile logand doesn't handle bignums.
1133 * This (primitive) version handles them up to 32 bits.
1136 SCM_PROC1 (s_sys_logand
, "%logand", scm_tc7_asubr
, scm_sys_logand
);
1138 static unsigned long
1139 scm_sloppy_num2ulong (SCM num
, char *pos
, const char *s_caller
)
1143 if (SCM_INUMP (num
))
1145 if (SCM_INUM (num
) < 0)
1147 res
= SCM_INUM (num
);
1150 SCM_ASRTGO (SCM_NIMP (num
), wrong_type_arg
);
1156 for (l
= SCM_NUMDIGS (num
); l
--;)
1157 res
= SCM_BIGUP (res
) + SCM_BDIGITS (num
)[l
];
1161 scm_wrong_type_arg (s_caller
, (int) pos
, num
);
1163 scm_out_of_range (s_caller
, num
);
1167 scm_sys_logand (SCM n1
, SCM n2
)
1169 if (SCM_UNBNDP (n2
))
1171 if (SCM_UNBNDP (n1
))
1172 return SCM_MAKINUM (-1);
1176 unsigned long u1
= scm_sloppy_num2ulong (n1
, (char *) 1, s_sys_logand
);
1177 unsigned long u2
= scm_sloppy_num2ulong (n2
, (char *) 2, s_sys_logand
);
1178 return scm_ulong2num (u1
& u2
);
1182 /* ======================================== */
1184 SCM_PROC (s_slot_ref_using_class
, "slot-ref-using-class", 3, 0, 0, scm_slot_ref_using_class
);
1187 scm_slot_ref_using_class (SCM
class, SCM obj
, SCM slot_name
)
1191 SCM_ASSERT (SCM_NIMP (class) && CLASSP (class),
1192 class, SCM_ARG1
, s_slot_ref_using_class
);
1193 SCM_ASSERT (SCM_NIMP (obj
) && SCM_INSTANCEP (obj
),
1194 obj
, SCM_ARG1
, s_slot_ref_using_class
);
1195 SCM_ASSERT (SCM_NIMP (slot_name
) && SCM_SYMBOLP (slot_name
),
1196 obj
, SCM_ARG3
, s_slot_ref_using_class
);
1198 res
= get_slot_value_using_name (class, obj
, slot_name
);
1199 if (SCM_GOOPS_UNBOUNDP (res
))
1200 return CALL_GF3 ("slot-unbound", class, obj
, slot_name
);
1204 SCM_PROC (s_slot_set_using_class_x
, "slot-set-using-class!", 4, 0, 0, scm_slot_set_using_class_x
);
1207 scm_slot_set_using_class_x (SCM
class, SCM obj
, SCM slot_name
, SCM value
)
1209 SCM_ASSERT (SCM_NIMP (class) && CLASSP (class),
1210 class, SCM_ARG1
, s_slot_set_using_class_x
);
1211 SCM_ASSERT (SCM_NIMP (obj
) && SCM_INSTANCEP (obj
),
1212 obj
, SCM_ARG2
, s_slot_set_using_class_x
);
1213 SCM_ASSERT (SCM_NIMP (slot_name
) && SCM_SYMBOLP (slot_name
),
1214 obj
, SCM_ARG3
, s_slot_set_using_class_x
);
1215 return set_slot_value_using_name (class, obj
, slot_name
, value
);
1218 SCM_PROC (s_slot_bound_using_class_p
, "slot-bound-using-class?", 3, 0, 0, scm_slot_bound_using_class_p
);
1221 scm_slot_bound_using_class_p (SCM
class, SCM obj
, SCM slot_name
)
1223 SCM_ASSERT (SCM_NIMP (class) && CLASSP (class),
1224 class, SCM_ARG1
, s_slot_bound_using_class_p
);
1225 SCM_ASSERT (SCM_NIMP (obj
) && SCM_INSTANCEP (obj
),
1226 obj
, SCM_ARG2
, s_slot_bound_using_class_p
);
1227 SCM_ASSERT (SCM_NIMP (slot_name
) && SCM_SYMBOLP (slot_name
),
1228 obj
, SCM_ARG3
, s_slot_bound_using_class_p
);
1230 return (SCM_GOOPS_UNBOUNDP (get_slot_value_using_name (class, obj
, slot_name
))
1235 SCM_PROC (s_slot_exists_using_class_p
, "slot-exists-using-class?", 3, 0, 0, scm_slot_exists_using_class_p
);
1238 scm_slot_exists_using_class_p (SCM
class, SCM obj
, SCM slot_name
)
1240 SCM_ASSERT (SCM_NIMP (class) && CLASSP (class),
1241 class, SCM_ARG1
, s_slot_exists_using_class_p
);
1242 SCM_ASSERT (SCM_NIMP (obj
) && SCM_INSTANCEP (obj
),
1243 obj
, SCM_ARG2
, s_slot_exists_using_class_p
);
1244 SCM_ASSERT (SCM_NIMP (slot_name
) && SCM_SYMBOLP (slot_name
),
1245 obj
, SCM_ARG3
, s_slot_exists_using_class_p
);
1246 return test_slot_existence (class, obj
, slot_name
);
1250 /* ======================================== */
1252 SCM_PROC (s_slot_ref
, "slot-ref", 2, 0, 0, scm_slot_ref
);
1255 scm_slot_ref (SCM obj
, SCM slot_name
)
1259 SCM_ASSERT (SCM_NIMP (obj
) && SCM_INSTANCEP (obj
),
1260 obj
, SCM_ARG1
, s_slot_ref
);
1261 TEST_CHANGE_CLASS (obj
, class);
1263 res
= get_slot_value_using_name (class, obj
, slot_name
);
1264 if (SCM_GOOPS_UNBOUNDP (res
))
1265 return CALL_GF3 ("slot-unbound", class, obj
, slot_name
);
1269 SCM_PROC (s_slot_set_x
, "slot-set!", 3, 0, 0, scm_slot_set_x
);
1271 const char *scm_s_slot_set_x
= s_slot_set_x
;
1274 scm_slot_set_x (SCM obj
, SCM slot_name
, SCM value
)
1278 SCM_ASSERT (SCM_NIMP (obj
) && SCM_INSTANCEP (obj
),
1279 obj
, SCM_ARG1
, s_slot_set_x
);
1280 TEST_CHANGE_CLASS(obj
, class);
1282 return set_slot_value_using_name (class, obj
, slot_name
, value
);
1285 SCM_PROC (s_slot_bound_p
, "slot-bound?", 2, 0, 0, scm_slot_bound_p
);
1288 scm_slot_bound_p (SCM obj
, SCM slot_name
)
1292 SCM_ASSERT (SCM_NIMP (obj
) && SCM_INSTANCEP (obj
),
1293 obj
, SCM_ARG1
, s_slot_bound_p
);
1294 TEST_CHANGE_CLASS(obj
, class);
1296 return (SCM_GOOPS_UNBOUNDP (get_slot_value_using_name (class,
1303 SCM_PROC (s_slot_exists_p
, "slot-exists?", 2, 0, 0, scm_slots_exists_p
);
1306 scm_slots_exists_p (SCM obj
, SCM slot_name
)
1310 SCM_ASSERT (SCM_NIMP (obj
) && SCM_INSTANCEP (obj
),
1311 obj
, SCM_ARG1
, s_slot_exists_p
);
1312 SCM_ASSERT (SCM_NIMP (slot_name
) && SCM_SYMBOLP (slot_name
),
1313 slot_name
, SCM_ARG2
, s_slot_exists_p
);
1314 TEST_CHANGE_CLASS (obj
, class);
1316 return test_slot_existence (class, obj
, slot_name
);
1320 /******************************************************************************
1322 * %allocate-instance (the low level instance allocation primitive)
1324 ******************************************************************************/
1326 static void clear_method_cache (SCM
);
1329 wrap_init (SCM
class, SCM
*m
, int n
)
1334 /* Set all slots to unbound */
1335 for (i
= 0; i
< n
; i
++)
1336 m
[i
] = SCM_GOOPS_UNBOUND
;
1339 SCM_SETCDR (z
, (SCM
) m
);
1340 SCM_SET_STRUCT_GC_CHAIN (z
, 0);
1341 SCM_SETCAR (z
, (scm_bits_t
) SCM_STRUCT_DATA (class) | scm_tc3_cons_gloc
);
1346 SCM_PROC (s_sys_allocate_instance
, "%allocate-instance", 2, 0, 0, scm_sys_allocate_instance
);
1349 scm_sys_allocate_instance (SCM
class, SCM initargs
)
1354 SCM_ASSERT (SCM_NIMP (class) && CLASSP (class),
1355 class, SCM_ARG1
, s_sys_allocate_instance
);
1357 /* Most instances */
1358 if (SCM_CLASS_FLAGS (class) & SCM_STRUCTF_LIGHT
)
1360 n
= SCM_INUM (SCM_SLOT (class, scm_si_nfields
));
1361 m
= (SCM
*) scm_must_malloc (n
* sizeof (SCM
), "instance");
1362 return wrap_init (class, m
, n
);
1365 /* Foreign objects */
1366 if (SCM_CLASS_FLAGS (class) & SCM_CLASSF_FOREIGN
)
1367 return scm_make_foreign_object (class, initargs
);
1369 n
= SCM_INUM (SCM_SLOT (class, scm_si_nfields
));
1372 if (SCM_CLASS_FLAGS (class) & SCM_CLASSF_ENTITY
)
1374 m
= (SCM
*) scm_alloc_struct (n
,
1375 scm_struct_entity_n_extra_words
,
1377 m
[scm_struct_i_setter
] = SCM_BOOL_F
;
1378 m
[scm_struct_i_procedure
] = SCM_BOOL_F
;
1379 /* Generic functions */
1380 if (SCM_CLASS_FLAGS (class) & SCM_CLASSF_PURE_GENERIC
)
1382 SCM gf
= wrap_init (class, m
, n
);
1383 clear_method_cache (gf
);
1387 return wrap_init (class, m
, n
);
1391 if (SCM_CLASS_FLAGS (class) & SCM_CLASSF_METACLASS
)
1395 /* allocate class object */
1396 SCM z
= scm_make_struct (class, SCM_INUM0
, SCM_EOL
);
1398 SCM_SLOT (z
, scm_si_print
) = SCM_GOOPS_UNBOUND
;
1399 for (i
= scm_si_goops_fields
; i
< n
; i
++)
1400 SCM_SLOT (z
, i
) = SCM_GOOPS_UNBOUND
;
1402 if (SCM_SUBCLASSP (class, scm_class_entity_class
))
1403 SCM_SET_CLASS_FLAGS (z
, SCM_CLASSF_OPERATOR
| SCM_CLASSF_ENTITY
);
1404 else if (SCM_SUBCLASSP (class, scm_class_operator_class
))
1405 SCM_SET_CLASS_FLAGS (z
, SCM_CLASSF_OPERATOR
);
1410 /* Non-light instances */
1412 m
= (SCM
*) scm_alloc_struct (n
,
1413 scm_struct_n_extra_words
,
1415 return wrap_init (class, m
, n
);
1419 SCM_PROC (s_sys_set_object_setter_x
, "%set-object-setter!", 2, 0, 0, scm_sys_set_object_setter_x
);
1422 scm_sys_set_object_setter_x (SCM obj
, SCM setter
)
1424 SCM_ASSERT (SCM_NIMP (obj
) && SCM_STRUCTP (obj
)
1425 && ((SCM_CLASS_FLAGS (obj
) & SCM_CLASSF_OPERATOR
)
1426 || SCM_I_ENTITYP (obj
)),
1429 s_sys_set_object_setter_x
);
1430 if (SCM_I_ENTITYP (obj
))
1431 SCM_ENTITY_SETTER (obj
) = setter
;
1433 SCM_OPERATOR_CLASS (obj
)->setter
= setter
;
1434 return SCM_UNSPECIFIED
;
1437 /******************************************************************************
1439 * %modify-instance (used by change-class to modify in place)
1441 ******************************************************************************/
1443 SCM_PROC (s_sys_modify_instance
, "%modify-instance", 2, 0, 0, scm_sys_modify_instance
);
1446 scm_sys_modify_instance (SCM old
, SCM
new)
1448 SCM_ASSERT (SCM_NIMP (old
) && SCM_INSTANCEP (old
),
1449 old
, SCM_ARG1
, s_sys_modify_instance
);
1450 SCM_ASSERT (SCM_NIMP (new) && SCM_INSTANCEP (new),
1451 new, SCM_ARG2
, s_sys_modify_instance
);
1453 /* Exchange the data contained in old and new. We exchange rather than
1454 * scratch the old value with new to be correct with GC.
1455 * See "Class redefinition protocol above".
1459 SCM car
= SCM_CAR (old
);
1460 SCM cdr
= SCM_CDR (old
);
1461 SCM_SETCAR (old
, SCM_CAR (new));
1462 SCM_SETCDR (old
, SCM_CDR (new));
1463 SCM_SETCAR (new, car
);
1464 SCM_SETCDR (new, cdr
);
1467 return SCM_UNSPECIFIED
;
1470 SCM_PROC (s_sys_modify_class
, "%modify-class", 2, 0, 0, scm_sys_modify_class
);
1473 scm_sys_modify_class (SCM old
, SCM
new)
1475 SCM_ASSERT (SCM_NIMP (old
) && CLASSP (old
),
1476 old
, SCM_ARG1
, s_sys_modify_class
);
1477 SCM_ASSERT (SCM_NIMP (new) && CLASSP (new),
1478 new, SCM_ARG2
, s_sys_modify_class
);
1482 SCM car
= SCM_CAR (old
);
1483 SCM cdr
= SCM_CDR (old
);
1484 SCM_SETCAR (old
, SCM_CAR (new));
1485 SCM_SETCDR (old
, SCM_CDR (new));
1486 SCM_STRUCT_DATA (old
)[scm_vtable_index_vtable
] = old
;
1487 SCM_SETCAR (new, car
);
1488 SCM_SETCDR (new, cdr
);
1489 SCM_STRUCT_DATA (new)[scm_vtable_index_vtable
] = new;
1492 return SCM_UNSPECIFIED
;
1495 SCM_PROC (s_sys_invalidate_class
, "%invalidate-class", 1, 0, 0, scm_sys_invalidate_class
);
1498 scm_sys_invalidate_class (SCM
class)
1500 SCM_ASSERT (SCM_NIMP (class) && CLASSP (class),
1501 class, SCM_ARG1
, s_sys_invalidate_class
);
1503 SCM_CLEAR_CLASS_FLAGS (class, SCM_CLASSF_GOOPS_VALID
);
1504 return SCM_UNSPECIFIED
;
1507 /* When instances change class, they finally get a new body, but
1508 * before that, they go through purgatory in hell. Odd as it may
1509 * seem, this data structure saves us from eternal suffering in
1510 * infinite recursions.
1514 static int n_hell
= 1; /* one place for the evil one himself */
1515 static int hell_size
= 4;
1517 static scm_mutex_t hell_mutex
;
1524 for (i
= 1; i
< n_hell
; ++i
)
1525 if (SCM_INST (o
) == hell
[i
])
1531 go_to_hell (void *o
)
1535 scm_mutex_lock (&hell_mutex
);
1537 if (n_hell
== hell_size
)
1539 int new_size
= 2 * hell_size
;
1540 hell
= scm_must_realloc (hell
, hell_size
, new_size
, "hell");
1541 hell_size
= new_size
;
1543 hell
[n_hell
++] = SCM_INST (obj
);
1545 scm_mutex_unlock (&hell_mutex
);
1550 go_to_heaven (void *o
)
1553 scm_mutex_lock (&hell_mutex
);
1555 hell
[burnin ((SCM
) o
)] = hell
[--n_hell
];
1557 scm_mutex_unlock (&hell_mutex
);
1562 purgatory (void *args
)
1564 return scm_apply (GETVAR (Intern ("change-class")), (SCM
) args
, SCM_EOL
);
1568 scm_change_object_class (SCM obj
, SCM old_class
, SCM new_class
)
1571 scm_internal_dynamic_wind (go_to_hell
, purgatory
, go_to_heaven
,
1572 (void *) SCM_LIST2 (obj
, new_class
),
1576 /******************************************************************************
1582 * GGG E N E R I C F U N C T I O N S
1584 * This implementation provides
1585 * - generic functions (with class specializers)
1588 * - a hard-coded MOP for standard gf, which can be overloaded for non-std gf
1590 ******************************************************************************/
1592 SCM_KEYWORD (k_name
, "name");
1594 SCM_SYMBOL (sym_no_method
, "no-method");
1596 static SCM list_of_no_method
;
1598 SCM_SYMBOL (scm_sym_args
, "args");
1601 scm_make_method_cache (SCM gf
)
1603 return SCM_LIST5 (SCM_IM_DISPATCH
, scm_sym_args
, SCM_MAKINUM (1),
1604 scm_make_vector (SCM_MAKINUM (SCM_INITIAL_MCACHE_SIZE
),
1610 clear_method_cache (SCM gf
)
1612 SCM_ENTITY_PROCEDURE (gf
) = scm_make_method_cache (gf
);
1613 SCM_SLOT (gf
, scm_si_used_by
) = SCM_BOOL_F
;
1616 SCM_PROC (s_sys_invalidate_method_cache_x
, "%invalidate-method-cache!", 1, 0, 0, scm_sys_invalidate_method_cache_x
);
1619 scm_sys_invalidate_method_cache_x (SCM gf
)
1622 SCM_ASSERT (SCM_NIMP (gf
) && SCM_STRUCTP (gf
) && SCM_PUREGENERICP (gf
),
1623 gf
, SCM_ARG1
, s_sys_invalidate_method_cache_x
);
1624 used_by
= SCM_SLOT (gf
, scm_si_used_by
);
1625 if (SCM_NFALSEP (used_by
))
1627 SCM methods
= SCM_SLOT (gf
, scm_si_methods
);
1628 for (; SCM_NIMP (used_by
) && SCM_CONSP (used_by
);
1629 used_by
= SCM_CDR (used_by
))
1630 scm_sys_invalidate_method_cache_x (SCM_CAR (used_by
));
1631 clear_method_cache (gf
);
1632 for (; SCM_NIMP (methods
) && SCM_CONSP (methods
);
1633 methods
= SCM_CDR (methods
))
1634 SCM_SLOT (SCM_CAR (methods
), scm_si_code_table
) = SCM_EOL
;
1637 SCM n
= SCM_SLOT (gf
, scm_si_n_specialized
);
1638 /* The sign of n is a flag indicating rest args. */
1639 SCM_SET_MCACHE_N_SPECIALIZED (SCM_ENTITY_PROCEDURE (gf
), n
);
1641 return SCM_UNSPECIFIED
;
1644 SCM_PROC (s_generic_capability_p
, "generic-capability?", 1, 0, 0, scm_generic_capability_p
);
1647 scm_generic_capability_p (SCM proc
)
1649 SCM_ASSERT (SCM_NFALSEP (scm_procedure_p (proc
)),
1650 proc
, SCM_ARG1
, s_generic_capability_p
);
1651 return (scm_subr_p (proc
) && SCM_SUBR_GENERIC (proc
)
1656 SCM_PROC (s_enable_primitive_generic_x
, "enable-primitive-generic!", 0, 0, 1, scm_enable_primitive_generic_x
);
1659 scm_enable_primitive_generic_x (SCM subrs
)
1661 while (SCM_NIMP (subrs
))
1663 SCM subr
= SCM_CAR (subrs
);
1664 SCM_ASSERT (scm_subr_p (subr
) && SCM_SUBR_GENERIC (subr
),
1665 subr
, SCM_ARGn
, s_enable_primitive_generic_x
);
1666 *SCM_SUBR_GENERIC (subr
)
1667 = scm_make (SCM_LIST3 (scm_class_generic
,
1670 subrs
= SCM_CDR (subrs
);
1672 return SCM_UNSPECIFIED
;
1675 SCM_PROC (s_primitive_generic_generic
, "primitive-generic-generic", 1, 0, 0, scm_primitive_generic_generic
);
1678 scm_primitive_generic_generic (SCM subr
)
1680 if (scm_subr_p (subr
) && SCM_SUBR_GENERIC (subr
))
1682 SCM gf
= *SCM_SUBR_GENERIC (subr
);
1686 return scm_wta (subr
, (char *) SCM_ARG1
, s_primitive_generic_generic
);
1689 /******************************************************************************
1691 * Protocol for calling a generic fumction
1692 * This protocol is roughly equivalent to (parameter are a little bit different
1693 * for efficiency reasons):
1695 * + apply-generic (gf args)
1696 * + compute-applicable-methods (gf args ...)
1697 * + sort-applicable-methods (methods args)
1698 * + apply-methods (gf methods args)
1700 * apply-methods calls make-next-method to build the "continuation" of a a
1701 * method. Applying a next-method will call apply-next-method which in
1702 * turn will call apply again to call effectively the following method.
1704 ******************************************************************************/
1707 applicablep (SCM actual
, SCM formal
)
1711 /* We test that (memq formal (slot-ref actual 'cpl))
1712 * However, we don't call memq here since we already know that
1713 * the list is well formed
1715 for (ptr
=SCM_SLOT(actual
, scm_si_cpl
); SCM_NNULLP(ptr
); ptr
= SCM_CDR(ptr
)) {
1716 if (SCM_NIMP (ptr
) && SCM_CONSP (ptr
)) {
1717 if (SCM_CAR (ptr
) == formal
)
1722 "Internal error in applicable: bad list ~S",
1723 SCM_LIST1 (actual
));
1729 more_specificp (SCM m1
, SCM m2
, SCM
*targs
)
1731 register SCM s1
, s2
;
1735 * m1 and m2 can have != length (i.e. one can be one element longer than the
1736 * other when we have a dotted parameter list). For instance, with the call
1739 * (define-method M (a . l) ....)
1740 * (define-method M (a) ....)
1742 * we consider that the second method is more specific.
1744 * BTW, targs is an array of types. We don't need it's size since
1745 * we already know that m1 and m2 are applicable (no risk to go past
1746 * the end of this array).
1749 for (i
=0,s1
=SPEC_OF(m1
),s2
=SPEC_OF(m2
); ; i
++,s1
=SCM_CDR(s1
),s2
=SCM_CDR(s2
)) {
1750 if (SCM_NULLP(s1
)) return 1;
1751 if (SCM_NULLP(s2
)) return 0;
1752 if (SCM_CAR(s1
) != SCM_CAR(s2
)) {
1753 register SCM l
, cs1
= SCM_CAR(s1
), cs2
= SCM_CAR(s2
);
1755 for (l
= SCM_SLOT(targs
[i
], scm_si_cpl
); ; l
= SCM_CDR(l
)) {
1756 if (cs1
== SCM_CAR(l
))
1758 if (cs2
== SCM_CAR(l
))
1761 return 0;/* should not occur! */
1764 return 0; /* should not occur! */
1767 #define BUFFSIZE 32 /* big enough for most uses */
1770 scm_i_vector2list (SCM l
, int len
)
1773 SCM z
= scm_make_vector (SCM_MAKINUM (len
), SCM_UNDEFINED
);
1775 for (j
= 0; j
< len
; j
++, l
= SCM_CDR (l
)) {
1776 SCM_VELTS (z
)[j
] = SCM_CAR (l
);
1782 sort_applicable_methods (SCM method_list
, int size
, SCM
*targs
)
1785 SCM
*v
, vector
= SCM_EOL
;
1786 SCM buffer
[BUFFSIZE
];
1787 SCM save
= method_list
;
1789 /* For reasonably sized method_lists we can try to avoid all the
1790 * consing and reorder the list in place...
1791 * This idea is due to David McClain <Dave_McClain@msn.com>
1793 if (size
<= BUFFSIZE
)
1795 for (i
= 0; i
< size
; i
++)
1797 buffer
[i
] = SCM_CAR (method_list
);
1798 method_list
= SCM_CDR (method_list
);
1804 /* Too many elements in method_list to keep everything locally */
1805 vector
= scm_i_vector2list (save
, size
);
1806 v
= SCM_VELTS (vector
);
1809 /* Use a simple shell sort since it is generally faster than qsort on
1810 * small vectors (which is probably mostly the case when we have to
1811 * sort a list of applicable methods).
1813 for (incr
= size
/ 2; incr
; incr
/= 2)
1815 for (i
= incr
; i
< size
; i
++)
1817 for (j
= i
- incr
; j
>= 0; j
-= incr
)
1819 if (more_specificp (v
[j
], v
[j
+incr
], targs
))
1823 SCM tmp
= v
[j
+ incr
];
1831 if (size
<= BUFFSIZE
)
1833 /* We did it in locally, so restore the original list (reordered) in-place */
1834 for (i
= 0, method_list
= save
; i
< size
; i
++, v
++)
1836 SCM_SETCAR (method_list
, *v
);
1837 method_list
= SCM_CDR (method_list
);
1841 /* If we are here, that's that we did it the hard way... */
1842 return scm_vector_to_list (vector
);
1846 scm_compute_applicable_methods (SCM gf
, SCM args
, int len
, int find_method_p
)
1850 SCM l
, fl
, applicable
= SCM_EOL
;
1852 SCM buffer
[BUFFSIZE
], *types
, *p
;
1855 /* Build the list of arguments types */
1856 if (len
>= BUFFSIZE
) {
1857 tmp
= scm_make_vector (SCM_MAKINUM (len
), SCM_UNDEFINED
);
1858 /* NOTE: Using pointers to malloced memory won't work if we
1859 1. have preemtive threading, and,
1860 2. have a GC which moves objects. */
1861 types
= p
= SCM_VELTS(tmp
);
1866 for ( ; SCM_NNULLP (args
); args
= SCM_CDR (args
))
1867 *p
++ = scm_class_of (SCM_CAR (args
));
1869 /* Build a list of all applicable methods */
1870 for (l
= SCM_SLOT (gf
, scm_si_methods
); SCM_NNULLP (l
); l
= SCM_CDR (l
))
1872 fl
= SPEC_OF (SCM_CAR (l
));
1873 /* Only accept accessors which match exactly in first arg. */
1874 if (SCM_ACCESSORP (SCM_CAR (l
))
1875 && (SCM_IMP (fl
) || types
[0] != SCM_CAR (fl
)))
1877 for (i
= 0; ; i
++, fl
= SCM_CDR (fl
))
1879 if ((SCM_NIMP (fl
) && SCM_INSTANCEP (fl
))
1880 /* We have a dotted argument list */
1881 || (i
>= len
&& SCM_NULLP (fl
)))
1882 { /* both list exhausted */
1883 applicable
= scm_cons (SCM_CAR (l
), applicable
);
1889 || !applicablep (types
[i
], SCM_CAR (fl
)))
1898 CALL_GF2 ("no-applicable-method", gf
, save
);
1899 /* if we are here, it's because no-applicable-method hasn't signaled an error */
1904 : sort_applicable_methods (applicable
, count
, types
));
1908 SCM_PROC (s_sys_compute_applicable_methods
, "%compute-applicable-methods", 2, 0, 0, scm_sys_compute_applicable_methods
);
1911 static const char s_sys_compute_applicable_methods
[] = "%compute-applicable-methods";
1914 scm_sys_compute_applicable_methods (SCM gf
, SCM args
)
1917 SCM_ASSERT (SCM_NIMP (gf
) && GENERICP (gf
),
1918 gf
, SCM_ARG1
, s_sys_compute_applicable_methods
);
1919 n
= scm_ilength (args
);
1920 SCM_ASSERT (n
>= 0, args
, SCM_ARG2
, s_sys_compute_applicable_methods
);
1921 return scm_compute_applicable_methods (gf
, args
, n
, 1);
1924 SCM_VCELL_INIT (var_compute_applicable_methods
, "compute-applicable-methods", scm_make_gsubr (s_sys_compute_applicable_methods
, 2, 0, 0, scm_sys_compute_applicable_methods
));
1926 SCM_SYNTAX (s_atslot_ref
, "@slot-ref", scm_makmmacro
, scm_m_atslot_ref
);
1929 scm_m_atslot_ref (SCM xorig
, SCM env
)
1931 SCM x
= SCM_CDR (xorig
);
1932 SCM_ASSYNT (scm_ilength (x
) == 2, xorig
, scm_s_expression
, s_atslot_ref
);
1933 SCM_ASSYNT (SCM_INUMP (SCM_CADR (x
)), SCM_CADR (x
), SCM_ARG2
, s_atslot_ref
);
1934 return scm_cons (SCM_IM_SLOT_REF
, x
);
1937 SCM_SYNTAX (s_atslot_set_x
, "@slot-set!", scm_makmmacro
, scm_m_atslot_set_x
);
1940 scm_m_atslot_set_x (SCM xorig
, SCM env
)
1942 SCM x
= SCM_CDR (xorig
);
1943 SCM_ASSYNT (scm_ilength (x
) == 3, xorig
, scm_s_expression
, s_atslot_set_x
);
1944 SCM_ASSYNT (SCM_INUMP (SCM_CADR (x
)), SCM_CADR (x
), SCM_ARG2
, s_atslot_set_x
);
1945 return scm_cons (SCM_IM_SLOT_SET_X
, x
);
1948 SCM_SYNTAX (s_atdispatch
, "@dispatch", scm_makmmacro
, scm_m_atdispatch
);
1950 SCM_SYMBOL (sym_atdispatch
, s_atdispatch
);
1953 scm_m_atdispatch (SCM xorig
, SCM env
)
1955 SCM args
, n
, v
, gf
, x
= SCM_CDR (xorig
);
1956 SCM_ASSYNT (scm_ilength (x
) == 4, xorig
, scm_s_expression
, s_atdispatch
);
1958 SCM_ASSYNT (SCM_NIMP (args
) && (SCM_CONSP (args
) || SCM_SYMBOLP (args
)),
1959 args
, SCM_ARG1
, s_atdispatch
);
1961 n
= SCM_XEVALCAR (x
, env
);
1962 SCM_ASSYNT (SCM_INUMP (n
), n
, SCM_ARG2
, s_atdispatch
);
1963 SCM_ASSYNT (SCM_INUM (n
) >= 1, n
, SCM_OUTOFRANGE
, s_atdispatch
);
1965 v
= SCM_XEVALCAR (x
, env
);
1966 SCM_ASSYNT (SCM_NIMP (v
) && SCM_VECTORP (v
), v
, SCM_ARG3
, s_atdispatch
);
1968 gf
= SCM_XEVALCAR (x
, env
);
1969 SCM_ASSYNT (SCM_NIMP (gf
) && SCM_STRUCTP (gf
) && SCM_PUREGENERICP (gf
),
1970 gf
, SCM_ARG4
, s_atdispatch
);
1971 return SCM_LIST5 (SCM_IM_DISPATCH
, args
, n
, v
, gf
);
1976 lock_cache_mutex (void *m
)
1978 SCM mutex
= (SCM
) m
;
1979 scm_lock_mutex (mutex
);
1983 unlock_cache_mutex (void *m
)
1985 SCM mutex
= (SCM
) m
;
1986 scm_unlock_mutex (mutex
);
1991 call_memoize_method (void *a
)
1994 SCM gf
= SCM_CAR (args
);
1995 SCM x
= SCM_CADR (args
);
1996 /* First check if another thread has inserted a method between
1997 * the cache miss and locking the mutex.
1999 SCM cmethod
= scm_mcache_lookup_cmethod (x
, SCM_CDDR (args
));
2000 if (SCM_NIMP (cmethod
))
2002 /*fixme* Use scm_apply */
2003 return CALL_GF3 ("memoize-method!", gf
, SCM_CDDR (args
), x
);
2007 scm_memoize_method (SCM x
, SCM args
)
2009 SCM gf
= SCM_CAR (scm_last_pair (x
));
2011 return scm_internal_dynamic_wind (lock_cache_mutex
,
2012 call_memoize_method
,
2014 (void *) scm_cons2 (gf
, x
, args
),
2015 (void *) SCM_SLOT (gf
, scm_si_cache_mutex
));
2017 return call_memoize_method ((void *) scm_cons2 (gf
, x
, args
));
2021 /******************************************************************************
2023 * A simple make (which will be redefined later in Scheme)
2024 * This version handles only creation of gf, methods and classes (no instances)
2026 * Since this code will disappear when Goops will be fully booted,
2027 * no precaution is taken to be efficient.
2029 ******************************************************************************/
2031 SCM_KEYWORD (k_setter
, "setter");
2032 SCM_KEYWORD (k_specializers
, "specializers");
2033 SCM_KEYWORD (k_procedure
, "procedure");
2034 SCM_KEYWORD (k_dsupers
, "dsupers");
2035 SCM_KEYWORD (k_slots
, "slots");
2036 SCM_KEYWORD (k_gf
, "generic-function");
2038 SCM_PROC (s_make
, "make", 0, 0, 1, scm_make
);
2044 int len
= scm_ilength (args
);
2046 if (len
<= 0 || (len
& 1) == 0)
2047 scm_wrong_num_args (scm_makfrom0str (s_make
));
2049 class = SCM_CAR(args
);
2050 args
= SCM_CDR(args
);
2052 if (class == scm_class_generic
|| class == scm_class_generic_with_setter
)
2055 z
= scm_make_struct (class, SCM_INUM0
,
2059 scm_make_mutex ()));
2061 z
= scm_make_struct (class, SCM_INUM0
,
2062 SCM_LIST3 (SCM_EOL
, SCM_INUM0
, SCM_BOOL_F
));
2064 scm_set_procedure_property_x (z
, scm_sym_name
,
2065 scm_get_keyword (k_name
,
2068 clear_method_cache (z
);
2069 if (class == scm_class_generic_with_setter
)
2071 SCM setter
= scm_get_keyword (k_setter
, args
, SCM_BOOL_F
);
2072 if (SCM_NIMP (setter
))
2073 scm_sys_set_object_setter_x (z
, setter
);
2078 z
= scm_sys_allocate_instance (class, args
);
2080 if (class == scm_class_method
2081 || class == scm_class_simple_method
2082 || class == scm_class_accessor
)
2084 SCM_SLOT (z
, scm_si_generic_function
) =
2085 scm_i_get_keyword (k_gf
,
2090 SCM_SLOT (z
, scm_si_specializers
) =
2091 scm_i_get_keyword (k_specializers
,
2096 SCM_SLOT (z
, scm_si_procedure
) =
2097 scm_i_get_keyword (k_procedure
,
2102 SCM_SLOT (z
, scm_si_code_table
) = SCM_EOL
;
2106 /* In all the others case, make a new class .... No instance here */
2107 SCM_SLOT (z
, scm_si_name
) =
2108 scm_i_get_keyword (k_name
,
2113 SCM_SLOT (z
, scm_si_direct_supers
) =
2114 scm_i_get_keyword (k_dsupers
,
2119 SCM_SLOT (z
, scm_si_direct_slots
) =
2120 scm_i_get_keyword (k_slots
,
2130 SCM_PROC (s_find_method
, "find-method", 0, 0, 1, scm_find_method
);
2133 scm_find_method (SCM l
)
2136 int len
= scm_ilength (l
);
2139 scm_wrong_num_args (scm_makfrom0str (s_find_method
));
2141 gf
= SCM_CAR(l
); l
= SCM_CDR(l
);
2142 SCM_ASSERT (SCM_NIMP (gf
) && GENERICP (gf
), gf
, SCM_ARG1
, s_find_method
);
2143 if (SCM_NULLP (SCM_SLOT (gf
, scm_si_methods
)))
2144 scm_misc_error (s_find_method
,
2145 "no methods for generic ~S",
2148 return scm_compute_applicable_methods (gf
, l
, len
- 1, 1);
2151 SCM_PROC (s_sys_method_more_specific_p
, "%method-more-specific?", 3, 0, 0, scm_sys_method_more_specific_p
);
2154 scm_sys_method_more_specific_p (SCM m1
, SCM m2
, SCM targs
)
2159 SCM_ASSERT (SCM_NIMP (m1
) && METHODP (m1
),
2160 m1
, SCM_ARG1
, s_sys_method_more_specific_p
);
2161 SCM_ASSERT (SCM_NIMP (m2
) && METHODP (m2
),
2162 m2
, SCM_ARG2
, s_sys_method_more_specific_p
);
2163 SCM_ASSERT ((len
= scm_ilength (targs
)) != -1,
2164 targs
, SCM_ARG3
, s_sys_method_more_specific_p
);
2166 /* Verify that all the arguments of targs are classes and place them in a vector*/
2167 v
= scm_make_vector (SCM_MAKINUM (len
), SCM_EOL
);
2169 for (i
=0, l
=targs
; SCM_NNULLP(l
); i
++, l
=SCM_CDR(l
)) {
2170 SCM_ASSERT (SCM_NIMP (SCM_CAR (l
)) && CLASSP (SCM_CAR (l
)),
2171 targs
, SCM_ARG3
, s_sys_method_more_specific_p
);
2172 SCM_VELTS(v
)[i
] = SCM_CAR(l
);
2174 return more_specificp (m1
, m2
, SCM_VELTS(v
)) ? SCM_BOOL_T
: SCM_BOOL_F
;
2179 /******************************************************************************
2183 ******************************************************************************/
2187 make_stdcls (SCM
*var
, char *name
, SCM meta
, SCM super
, SCM slots
)
2189 SCM tmp
= Intern(name
);
2191 *var
= scm_permanent_object (scm_basic_make_class (meta
,
2195 : SCM_LIST1 (super
),
2201 SCM_KEYWORD (k_slot_definition
, "slot-definition");
2204 create_standard_classes (void)
2207 SCM method_slots
= SCM_LIST4 (Intern ("generic-function"),
2208 Intern ("specializers"),
2209 Intern ("procedure"),
2210 Intern ("code-table"));
2211 SCM amethod_slots
= SCM_LIST1 (SCM_LIST3 (Intern ("slot-definition"),
2213 k_slot_definition
));
2215 SCM mutex_slot
= SCM_LIST1 (Intern ("make-mutex"));
2217 SCM mutex_slot
= SCM_BOOL_F
;
2219 SCM gf_slots
= SCM_LIST4 (Intern ("methods"),
2220 SCM_LIST3 (Intern ("n-specialized"),
2223 SCM_LIST3 (Intern ("used-by"),
2226 SCM_LIST3 (Intern ("cache-mutex"),
2228 scm_closure (SCM_LIST2 (SCM_EOL
,
2232 /* Foreign class slot classes */
2233 make_stdcls (&scm_class_foreign_slot
, "<foreign-slot>",
2234 scm_class_class
, scm_class_top
, SCM_EOL
);
2235 make_stdcls (&scm_class_protected
, "<protected-slot>",
2236 scm_class_class
, scm_class_foreign_slot
, SCM_EOL
);
2237 make_stdcls (&scm_class_opaque
, "<opaque-slot>",
2238 scm_class_class
, scm_class_foreign_slot
, SCM_EOL
);
2239 make_stdcls (&scm_class_read_only
, "<read-only-slot>",
2240 scm_class_class
, scm_class_foreign_slot
, SCM_EOL
);
2241 make_stdcls (&scm_class_self
, "<self-slot>",
2243 SCM_LIST2 (scm_class_foreign_slot
, scm_class_read_only
),
2245 make_stdcls (&scm_class_protected_opaque
, "<protected-opaque-slot>",
2247 SCM_LIST2 (scm_class_protected
, scm_class_opaque
),
2249 make_stdcls (&scm_class_protected_read_only
, "<protected-read-only-slot>",
2251 SCM_LIST2 (scm_class_protected
, scm_class_read_only
),
2253 make_stdcls (&scm_class_scm
, "<scm-slot>",
2254 scm_class_class
, scm_class_protected
, SCM_EOL
);
2255 make_stdcls (&scm_class_int
, "<int-slot>",
2256 scm_class_class
, scm_class_foreign_slot
, SCM_EOL
);
2257 make_stdcls (&scm_class_float
, "<float-slot>",
2258 scm_class_class
, scm_class_foreign_slot
, SCM_EOL
);
2259 make_stdcls (&scm_class_double
, "<double-slot>",
2260 scm_class_class
, scm_class_foreign_slot
, SCM_EOL
);
2262 /* Continue initialization of class <class> */
2264 slots
= build_class_class_slots ();
2265 SCM_SLOT (scm_class_class
, scm_si_direct_slots
) = slots
;
2266 SCM_SLOT (scm_class_class
, scm_si_slots
) = slots
;
2267 SCM_SLOT (scm_class_class
, scm_si_getters_n_setters
)
2268 = compute_getters_n_setters (slots
);
2270 make_stdcls (&scm_class_foreign_class
, "<foreign-class>",
2271 scm_class_class
, scm_class_class
,
2272 SCM_LIST2 (SCM_LIST3 (Intern ("constructor"),
2275 SCM_LIST3 (Intern ("destructor"),
2277 scm_class_opaque
)));
2278 make_stdcls (&scm_class_foreign_object
, "<foreign-object>",
2279 scm_class_foreign_class
, scm_class_object
, SCM_EOL
);
2280 SCM_SET_CLASS_FLAGS (scm_class_foreign_object
, SCM_CLASSF_FOREIGN
);
2282 /* scm_class_generic functions classes */
2283 make_stdcls (&scm_class_procedure_class
, "<procedure-class>",
2284 scm_class_class
, scm_class_class
, SCM_EOL
);
2285 make_stdcls (&scm_class_entity_class
, "<entity-class>",
2286 scm_class_class
, scm_class_procedure_class
, SCM_EOL
);
2287 make_stdcls (&scm_class_operator_class
, "<operator-class>",
2288 scm_class_class
, scm_class_procedure_class
, SCM_EOL
);
2289 make_stdcls (&scm_class_operator_with_setter_class
,
2290 "<operator-with-setter-class>",
2291 scm_class_class
, scm_class_operator_class
, SCM_EOL
);
2292 make_stdcls (&scm_class_method
, "<method>",
2293 scm_class_class
, scm_class_object
, method_slots
);
2294 make_stdcls (&scm_class_simple_method
, "<simple-method>",
2295 scm_class_class
, scm_class_method
, SCM_EOL
);
2296 SCM_SET_CLASS_FLAGS (scm_class_simple_method
, SCM_CLASSF_SIMPLE_METHOD
);
2297 make_stdcls (&scm_class_accessor
, "<accessor-method>",
2298 scm_class_class
, scm_class_simple_method
, amethod_slots
);
2299 SCM_SET_CLASS_FLAGS (scm_class_accessor
, SCM_CLASSF_ACCESSOR_METHOD
);
2300 make_stdcls (&scm_class_entity
, "<entity>",
2301 scm_class_entity_class
, scm_class_object
, SCM_EOL
);
2302 make_stdcls (&scm_class_entity_with_setter
, "<entity-with-setter>",
2303 scm_class_entity_class
, scm_class_entity
, SCM_EOL
);
2304 make_stdcls (&scm_class_generic
, "<generic>",
2305 scm_class_entity_class
, scm_class_entity
, gf_slots
);
2306 SCM_SET_CLASS_FLAGS (scm_class_generic
, SCM_CLASSF_PURE_GENERIC
);
2307 make_stdcls (&scm_class_generic_with_setter
, "<generic-with-setter>",
2308 scm_class_entity_class
,
2309 SCM_LIST2 (scm_class_generic
, scm_class_entity_with_setter
),
2312 /* Patch cpl since compute_cpl doesn't support multiple inheritance. */
2313 SCM_SLOT (scm_class_generic_with_setter
, scm_si_cpl
) =
2314 scm_append (SCM_LIST3 (SCM_LIST2 (scm_class_generic_with_setter
,
2316 SCM_SLOT (scm_class_entity_with_setter
,
2320 SCM_SET_CLASS_FLAGS (scm_class_generic_with_setter
, SCM_CLASSF_PURE_GENERIC
);
2322 /* Primitive types classes */
2323 make_stdcls (&scm_class_boolean
, "<boolean>",
2324 scm_class_class
, scm_class_top
, SCM_EOL
);
2325 make_stdcls (&scm_class_char
, "<char>",
2326 scm_class_class
, scm_class_top
, SCM_EOL
);
2327 make_stdcls (&scm_class_list
, "<list>",
2328 scm_class_class
, scm_class_top
, SCM_EOL
);
2329 make_stdcls (&scm_class_pair
, "<pair>",
2330 scm_class_class
, scm_class_list
, SCM_EOL
);
2331 make_stdcls (&scm_class_null
, "<null>",
2332 scm_class_class
, scm_class_list
, SCM_EOL
);
2333 make_stdcls (&scm_class_string
, "<string>",
2334 scm_class_class
, scm_class_top
, SCM_EOL
);
2335 make_stdcls (&scm_class_symbol
, "<symbol>",
2336 scm_class_class
, scm_class_top
, SCM_EOL
);
2337 make_stdcls (&scm_class_vector
, "<vector>",
2338 scm_class_class
, scm_class_top
, SCM_EOL
);
2339 make_stdcls (&scm_class_number
, "<number>",
2340 scm_class_class
, scm_class_top
, SCM_EOL
);
2341 make_stdcls (&scm_class_complex
, "<complex>",
2342 scm_class_class
, scm_class_number
, SCM_EOL
);
2343 make_stdcls (&scm_class_real
, "<real>",
2344 scm_class_class
, scm_class_complex
, SCM_EOL
);
2345 make_stdcls (&scm_class_integer
, "<integer>",
2346 scm_class_class
, scm_class_real
, SCM_EOL
);
2347 make_stdcls (&scm_class_keyword
, "<keyword>",
2348 scm_class_class
, scm_class_top
, SCM_EOL
);
2349 make_stdcls (&scm_class_unknown
, "<unknown>",
2350 scm_class_class
, scm_class_top
, SCM_EOL
);
2351 make_stdcls (&scm_class_procedure
, "<procedure>",
2352 scm_class_procedure_class
, scm_class_top
, SCM_EOL
);
2353 make_stdcls (&scm_class_procedure_with_setter
, "<procedure-with-setter>",
2354 scm_class_procedure_class
, scm_class_procedure
, SCM_EOL
);
2355 make_stdcls (&scm_class_primitive_generic
, "<primitive-generic>",
2356 scm_class_procedure_class
, scm_class_procedure
, SCM_EOL
);
2357 make_stdcls (&scm_class_port
, "<port>",
2358 scm_class_class
, scm_class_top
, SCM_EOL
);
2359 make_stdcls (&scm_class_input_port
, "<input-port>",
2360 scm_class_class
, scm_class_port
, SCM_EOL
);
2361 make_stdcls (&scm_class_output_port
, "<output-port>",
2362 scm_class_class
, scm_class_port
, SCM_EOL
);
2363 make_stdcls (&scm_class_input_output_port
, "<input-output-port>",
2365 SCM_LIST2 (scm_class_input_port
, scm_class_output_port
),
2369 /**********************************************************************
2373 **********************************************************************/
2376 make_class_from_template (char *template, char *type_name
, SCM supers
)
2382 sprintf (buffer
, template, type_name
);
2383 name
= Intern (buffer
);
2386 name
= SCM_GOOPS_UNBOUND
;
2388 class = scm_permanent_object (scm_basic_make_class (scm_class_class
,
2393 /* Only define name if doesn't already exist. */
2394 if (!SCM_GOOPS_UNBOUNDP (name
)
2395 && SCM_FALSEP (scm_apply (scm_goops_lookup_closure
,
2396 SCM_LIST2 (name
, SCM_BOOL_F
),
2399 /* Make sure we add the binding in the GOOPS module.
2400 * This kludge is needed until DEFVAR ceases to use `define-public'
2401 * or `define-public' ceases to use `current-module'.
2403 SCM old_module
= scm_select_module (scm_module_goops
);
2404 DEFVAR (name
, class);
2405 scm_select_module (old_module
);
2411 scm_make_extended_class (char *type_name
)
2413 return make_class_from_template ("<%s>",
2415 SCM_LIST1 (scm_class_top
));
2419 create_smob_classes (void)
2423 scm_smob_class
= (SCM
*) malloc (255 * sizeof (SCM
));
2424 for (i
= 0; i
< 255; ++i
)
2425 scm_smob_class
[i
] = 0;
2427 scm_smob_class
[SCM_TC2SMOBNUM (scm_tc16_big
)] = scm_class_integer
;
2428 scm_smob_class
[SCM_TC2SMOBNUM (scm_tc16_real
)] = scm_class_real
;
2429 scm_smob_class
[SCM_TC2SMOBNUM (scm_tc16_complex
)] = scm_class_complex
;
2430 scm_smob_class
[SCM_TC2SMOBNUM (scm_tc16_keyword
)] = scm_class_keyword
;
2432 for (i
= 0; i
< scm_numsmob
; ++i
)
2433 if (!scm_smob_class
[i
])
2434 scm_smob_class
[i
] = scm_make_extended_class (SCM_SMOBNAME (i
));
2438 scm_make_port_classes (int ptobnum
, char *type_name
)
2440 SCM c
, class = make_class_from_template ("<%s-port>",
2442 SCM_LIST1 (scm_class_port
));
2443 scm_port_class
[SCM_IN_PCLASS_INDEX
+ ptobnum
]
2444 = make_class_from_template ("<%s-input-port>",
2446 SCM_LIST2 (class, scm_class_input_port
));
2447 scm_port_class
[SCM_OUT_PCLASS_INDEX
+ ptobnum
]
2448 = make_class_from_template ("<%s-output-port>",
2450 SCM_LIST2 (class, scm_class_output_port
));
2451 scm_port_class
[SCM_INOUT_PCLASS_INDEX
+ ptobnum
]
2453 = make_class_from_template ("<%s-input-output-port>",
2456 scm_class_input_output_port
));
2457 /* Patch cpl (since this tree is too complex for the C level compute-cpl) */
2458 SCM_SLOT (c
, scm_si_cpl
)
2459 = scm_cons2 (c
, class, SCM_SLOT (scm_class_input_output_port
, scm_si_cpl
));
2463 create_port_classes (void)
2467 scm_port_class
= (SCM
*) malloc (3 * 256 * sizeof (SCM
));
2468 for (i
= 0; i
< 3 * 256; ++i
)
2469 scm_port_class
[i
] = 0;
2471 for (i
= 0; i
< scm_numptob
; ++i
)
2472 scm_make_port_classes (i
, SCM_PTOBNAME (i
));
2476 make_struct_class (void *closure
, SCM key
, SCM data
, SCM prev
)
2478 if (SCM_NFALSEP (SCM_STRUCT_TABLE_NAME (data
)))
2479 SCM_SET_STRUCT_TABLE_CLASS (data
,
2480 scm_make_extended_class
2481 (SCM_SYMBOL_CHARS (SCM_STRUCT_TABLE_NAME (data
))));
2482 return SCM_UNSPECIFIED
;
2486 create_struct_classes (void)
2488 scm_internal_hash_fold (make_struct_class
, 0, SCM_BOOL_F
, scm_struct_table
);
2491 /**********************************************************************
2495 **********************************************************************/
2500 if (!goops_loaded_p
)
2501 scm_resolve_module (scm_read_0str ("(oop goops)"));
2505 scm_make_foreign_object (SCM
class, SCM initargs
)
2507 void * (*constructor
) (SCM
)
2508 = (void * (*) (SCM
)) SCM_SLOT (class, scm_si_constructor
);
2509 SCM_ASSERT (constructor
!= 0, class, "Can't make instances of this class",
2511 return scm_wrap_object (class, constructor (initargs
));
2515 scm_free_foreign_object (SCM
*class, SCM
*data
)
2517 size_t (*destructor
) (void *)
2518 = (size_t (*) (void *)) class[scm_si_destructor
];
2519 return destructor (data
);
2523 scm_make_class (SCM meta
, char *s_name
, SCM supers
, size_t size
,
2524 void * (*constructor
) (SCM initargs
),
2525 size_t (*destructor
) (void *))
2528 name
= Intern (s_name
);
2529 if (SCM_IMP (supers
))
2530 supers
= SCM_LIST1 (scm_class_foreign_object
);
2531 class = scm_basic_basic_make_class (meta
, name
, supers
, SCM_EOL
);
2532 scm_sys_inherit_magic_x (class, supers
);
2534 if (destructor
!= 0)
2536 SCM_SLOT (class, scm_si_destructor
) = (SCM
) destructor
;
2537 SCM_SET_CLASS_DESTRUCTOR (class, scm_free_foreign_object
);
2541 SCM_SET_CLASS_DESTRUCTOR (class, scm_struct_free_light
);
2542 SCM_SET_CLASS_INSTANCE_SIZE (class, size
);
2545 SCM_SLOT (class, scm_si_layout
) = SCM_CAR (scm_intern ("", 0));
2546 SCM_SLOT (class, scm_si_constructor
) = (SCM
) constructor
;
2551 SCM_SYMBOL (sym_o
, "o");
2552 SCM_SYMBOL (sym_x
, "x");
2554 SCM_KEYWORD (k_accessor
, "accessor");
2555 SCM_KEYWORD (k_getter
, "getter");
2558 default_setter (SCM obj
, SCM c
)
2560 scm_misc_error ("slot-set!", "read-only slot", SCM_EOL
);
2565 scm_add_slot (SCM
class, char *slot_name
, SCM slot_class
,
2566 SCM (*getter
) (SCM obj
),
2567 SCM (*setter
) (SCM obj
, SCM x
),
2568 char *accessor_name
)
2571 SCM get
= scm_make_subr_opt ("goops:get", scm_tc7_subr_1
, getter
, 0);
2572 SCM set
= scm_make_subr_opt ("goops:set", scm_tc7_subr_2
,
2573 setter
? setter
: default_setter
, 0);
2574 SCM getm
= scm_closure (SCM_LIST2 (SCM_LIST1 (sym_o
),
2575 SCM_LIST2 (get
, sym_o
)),
2577 SCM setm
= scm_closure (SCM_LIST2 (SCM_LIST2 (sym_o
, sym_x
),
2578 SCM_LIST3 (set
, sym_o
, sym_x
)),
2581 SCM name
= SCM_CAR (scm_intern0 (slot_name
));
2582 SCM aname
= SCM_CAR (scm_intern0 (accessor_name
));
2583 SCM gf
= scm_ensure_accessor (aname
);
2584 SCM slot
= SCM_LIST5 (name
,
2585 k_class
, slot_class
,
2586 setter
? k_accessor
: k_getter
,
2588 SCM gns
= SCM_LIST4 (name
, SCM_BOOL_F
, get
, set
);
2590 scm_add_method (gf
, scm_make (SCM_LIST5 (scm_class_accessor
,
2593 k_procedure
, getm
)));
2594 scm_add_method (scm_setter (gf
),
2595 scm_make (SCM_LIST5 (scm_class_accessor
,
2599 k_procedure
, setm
)));
2602 SCM_SLOT (class, scm_si_slots
)
2603 = scm_append_x (SCM_LIST2 (SCM_SLOT (class, scm_si_slots
),
2605 SCM_SLOT (class, scm_si_getters_n_setters
)
2606 = scm_append_x (SCM_LIST2 (SCM_SLOT (class, scm_si_getters_n_setters
),
2611 int n
= SCM_INUM (SCM_SLOT (class, scm_si_nfields
));
2613 SCM_SLOT (class, scm_si_nfields
)
2614 = SCM_MAKINUM (n
+ 1);
2619 scm_wrap_object (SCM
class, void *data
)
2623 SCM_SETCDR (z
, (SCM
) data
);
2624 SCM_SET_STRUCT_GC_CHAIN (z
, 0);
2625 SCM_SETCAR (z
, SCM_UNPACK (SCM_CDR (class)) | scm_tc3_cons_gloc
);
2632 scm_wrap_component (SCM
class, SCM container
, void *data
)
2634 SCM obj
= scm_wrap_object (class, data
);
2635 SCM handle
= scm_hash_fn_create_handle_x (scm_components
,
2641 SCM_SETCDR (handle
, container
);
2646 scm_ensure_accessor (SCM name
)
2648 SCM gf
= scm_apply (SCM_TOP_LEVEL_LOOKUP_CLOSURE
,
2649 SCM_LIST2 (name
, SCM_BOOL_F
),
2651 if (!SCM_IS_A_P (gf
, scm_class_generic_with_setter
))
2653 gf
= scm_make (SCM_LIST3 (scm_class_generic
, k_name
, name
));
2654 gf
= scm_make (SCM_LIST5 (scm_class_generic_with_setter
,
2661 SCM_SYMBOL (sym_internal_add_method_x
, "internal-add-method!");
2664 scm_add_method (SCM gf
, SCM m
)
2666 scm_eval2 (SCM_LIST3 (sym_internal_add_method_x
, gf
, m
),
2667 scm_goops_lookup_closure
);
2672 * Debugging utilities
2675 SCM_PROC (s_pure_generic_p
, "pure-generic?", 1, 0, 0, scm_pure_generic_p
);
2678 scm_pure_generic_p (SCM obj
)
2680 return (SCM_NIMP (obj
) && SCM_STRUCTP (obj
) && SCM_PUREGENERICP (obj
)
2685 #endif /* GUILE_DEBUG */
2691 SCM_PROC (scm_sys_goops_loaded
, "%goops-loaded", 0, 0, 0, sys_goops_loaded
);
2697 var_compute_applicable_methods
2698 = SCM_CDR (scm_apply (scm_goops_lookup_closure
,
2699 SCM_LIST2 (SCM_CAR (var_compute_applicable_methods
),
2702 return SCM_UNSPECIFIED
;
2705 SCM scm_module_goops
;
2708 scm_init_goops (void)
2711 scm_module_goops
= scm_make_module (scm_read_0str ("(oop goops)"));
2712 old_module
= scm_select_module (scm_module_goops
);
2714 scm_goops_lookup_closure
= scm_module_lookup_closure (scm_module_goops
);
2716 scm_components
= scm_permanent_object (scm_make_weak_key_hash_table
2717 (SCM_MAKINUM (37)));
2719 goops_rstate
= scm_c_make_rstate ("GOOPS", 5);
2721 #ifndef SCM_MAGIC_SNARFER
2722 #include "libguile/goops.x"
2725 list_of_no_method
= scm_permanent_object (SCM_LIST1 (sym_no_method
));
2727 hell
= scm_must_malloc (hell_size
, "hell");
2729 scm_mutex_init (&hell_mutex
);
2732 create_basic_classes ();
2733 create_standard_classes ();
2734 create_smob_classes ();
2735 create_struct_classes ();
2736 create_port_classes ();
2739 SCM name
= SCM_CAR (scm_intern0 ("no-applicable-method"));
2740 scm_no_applicable_method
2741 = scm_permanent_object (scm_make (SCM_LIST3 (scm_class_generic
,
2744 DEFVAR (name
, scm_no_applicable_method
);
2747 scm_select_module (old_module
);
2751 scm_init_oop_goops_goopscore_module ()
2753 scm_register_module_xxx ("oop goops goopscore", (void *) scm_init_goops
);