#define SPEC_OF(x) SCM_SLOT (x, scm_si_specializers)
#define DEFVAR(v,val) \
-{ scm_i_eval (SCM_LIST3 (scm_sym_define_public, (v), (val)), \
- scm_top_level_env (scm_goops_lookup_closure)); }
+{ scm_eval (SCM_LIST3 (scm_sym_define_public, (v), (val)), \
+ scm_module_goops); }
/* Temporary hack until we get the new module system */
/*fixme* Should optimize by keeping track of the variable object itself */
#define GETVAR(v) (SCM_CDDR (scm_apply (scm_goops_lookup_closure, \
SCM_ASSERT (SCM_KEYWORDP (key), key, SCM_ARG1, FUNC_NAME);
len = scm_ilength (l);
- if (len < 0 || len % 1 == 1)
+ if (len < 0 || len % 2 == 1)
scm_misc_error (FUNC_NAME, "Bad keyword-value list: ~S", SCM_LIST1 (l));
return scm_i_get_keyword (key, l, len, default_value, FUNC_NAME);
SCM_DEFINE (scm_sys_initialize_object, "%initialize-object", 2, 0, 0,
(SCM obj, SCM initargs),
- "")
+ "Initialize the object @var{obj} with the given arguments\n"
+ "@var{initargs}.")
#define FUNC_NAME s_scm_sys_initialize_object
{
SCM tmp, get_n_set, slots;
SCM_DEFINE (scm_instance_p, "instance?", 1, 0, 0,
(SCM obj),
- "")
+ "Return @code{#t} if @var{obj} is an instance.")
#define FUNC_NAME s_scm_instance_p
{
return SCM_BOOL (SCM_INSTANCEP (obj));
******************************************************************************/
SCM_DEFINE (scm_class_name, "class-name", 1, 0, 0,
(SCM obj),
- "")
+ "Return the class name of @var{obj}.")
#define FUNC_NAME s_scm_class_name
{
SCM_VALIDATE_CLASS (1, obj);
SCM_DEFINE (scm_class_direct_supers, "class-direct-supers", 1, 0, 0,
(SCM obj),
- "")
+ "Return the direct superclasses of the class @var{obj}.")
#define FUNC_NAME s_scm_class_direct_supers
{
SCM_VALIDATE_CLASS (1, obj);
SCM_DEFINE (scm_class_direct_slots, "class-direct-slots", 1, 0, 0,
(SCM obj),
- "")
+ "Return the direct slots of the class @var{obj}.")
#define FUNC_NAME s_scm_class_direct_slots
{
SCM_VALIDATE_CLASS (1, obj);
SCM_DEFINE (scm_class_direct_subclasses, "class-direct-subclasses", 1, 0, 0,
(SCM obj),
- "")
+ "Return the direct subclasses of the class @var{obj}.")
#define FUNC_NAME s_scm_class_direct_subclasses
{
SCM_VALIDATE_CLASS (1, obj);
SCM_DEFINE (scm_class_direct_methods, "class-direct-methods", 1, 0, 0,
(SCM obj),
- "")
+ "Return the direct methods of the class @var{obj}")
#define FUNC_NAME s_scm_class_direct_methods
{
SCM_VALIDATE_CLASS (1, obj);
SCM_DEFINE (scm_class_precedence_list, "class-precedence-list", 1, 0, 0,
(SCM obj),
- "")
+ "Return the class precedence list of the class @var{obj}.")
#define FUNC_NAME s_scm_class_precedence_list
{
SCM_VALIDATE_CLASS (1, obj);
SCM_DEFINE (scm_class_slots, "class-slots", 1, 0, 0,
(SCM obj),
- "")
+ "Return the slot list of the class @var{obj}.")
#define FUNC_NAME s_scm_class_slots
{
SCM_VALIDATE_CLASS (1, obj);
SCM_DEFINE (scm_class_environment, "class-environment", 1, 0, 0,
(SCM obj),
- "")
+ "Return the environment of the class @var{obj}.")
#define FUNC_NAME s_scm_class_environment
{
SCM_VALIDATE_CLASS (1, obj);
SCM_DEFINE (scm_generic_function_name, "generic-function-name", 1, 0, 0,
(SCM obj),
- "")
+ "Return the name of the generic function @var{obj}.")
#define FUNC_NAME s_scm_generic_function_name
{
SCM_VALIDATE_GENERIC (1, obj);
SCM_DEFINE (scm_generic_function_methods, "generic-function-methods", 1, 0, 0,
(SCM obj),
- "")
+ "Return the methods of the generic function @var{obj}.")
#define FUNC_NAME s_scm_generic_function_methods
{
SCM_VALIDATE_GENERIC (1, obj);
SCM_DEFINE (scm_method_generic_function, "method-generic-function", 1, 0, 0,
(SCM obj),
- "")
+ "Return the generic function fot the method @var{obj}.")
#define FUNC_NAME s_scm_method_generic_function
{
SCM_VALIDATE_METHOD (1, obj);
SCM_DEFINE (scm_method_specializers, "method-specializers", 1, 0, 0,
(SCM obj),
- "")
+ "Return specializers of the method @var{obj}.")
#define FUNC_NAME s_scm_method_specializers
{
SCM_VALIDATE_METHOD (1, obj);
SCM_DEFINE (scm_method_procedure, "method-procedure", 1, 0, 0,
(SCM obj),
- "")
+ "Return the procedure of the method @var{obj}.")
#define FUNC_NAME s_scm_method_procedure
{
SCM_VALIDATE_METHOD (1, obj);
SCM_DEFINE (scm_accessor_method_slot_definition, "accessor-method-slot-definition", 1, 0, 0,
(SCM obj),
- "")
+ "Return the slot definition of the accessor @var{obj}.")
#define FUNC_NAME s_scm_accessor_method_slot_definition
{
SCM_VALIDATE_ACCESSOR (1, obj);
SCM_DEFINE (scm_make_unbound, "make-unbound", 0, 0, 0,
(),
- "")
+ "Return the unbound value.")
#define FUNC_NAME s_scm_make_unbound
{
return SCM_GOOPS_UNBOUND;
SCM_DEFINE (scm_unbound_p, "unbound?", 1, 0, 0,
(SCM obj),
- "")
+ "Return @code{#t} if @var{obj} is unbound.")
#define FUNC_NAME s_scm_unbound_p
{
return SCM_GOOPS_UNBOUNDP (obj) ? SCM_BOOL_T : SCM_BOOL_F;
SCM_DEFINE (scm_assert_bound, "assert-bound", 2, 0, 0,
(SCM value, SCM obj),
- "")
+ "Return @var{value} if it is bound, and invoke the\n"
+ "@var{slot-unbound} method of @var{obj} if it is not.")
#define FUNC_NAME s_scm_assert_bound
{
if (SCM_GOOPS_UNBOUNDP (value))
SCM_DEFINE (scm_at_assert_bound_ref, "@assert-bound-ref", 2, 0, 0,
(SCM obj, SCM index),
- "")
+ "Like @code{assert-bound}, but use @var{index} for accessing\n"
+ "the value from @var{obj}.")
#define FUNC_NAME s_scm_at_assert_bound_ref
{
SCM value = SCM_SLOT (obj, SCM_INUM (index));
SCM_DEFINE (scm_sys_fast_slot_ref, "%fast-slot-ref", 2, 0, 0,
(SCM obj, SCM index),
- "")
+ "Return the slot value with index @var{index} from @var{obj}.")
#define FUNC_NAME s_scm_sys_fast_slot_ref
{
register long i;
SCM_DEFINE (scm_sys_fast_slot_set_x, "%fast-slot-set!", 3, 0, 0,
(SCM obj, SCM index, SCM value),
- "")
+ "Set the slot with index @var{index} in @var{obj} to\n"
+ "@var{value}.")
#define FUNC_NAME s_scm_sys_fast_slot_set_x
{
register long i;
SCM_DEFINE (scm_slot_ref, "slot-ref", 2, 0, 0,
(SCM obj, SCM slot_name),
- "")
+ "Return the value from @var{obj}'s slot with the name\n"
+ "@var{slot_name}.")
#define FUNC_NAME s_scm_slot_ref
{
SCM res, class;
SCM_DEFINE (scm_slot_set_x, "slot-set!", 3, 0, 0,
(SCM obj, SCM slot_name, SCM value),
- "")
+ "Set the slot named @var{slot_name} of @var{obj} to @var{value}.")
#define FUNC_NAME s_scm_slot_set_x
{
SCM class;
SCM_DEFINE (scm_slot_bound_p, "slot-bound?", 2, 0, 0,
(SCM obj, SCM slot_name),
- "")
+ "Return @code{#t} if the slot named @var{slot_name} of @var{obj}\n"
+ "is bound.")
#define FUNC_NAME s_scm_slot_bound_p
{
SCM class;
SCM_DEFINE (scm_slots_exists_p, "slot-exists?", 2, 0, 0,
(SCM obj, SCM slot_name),
- "")
+ "Return @code{#t} if @var{obj} has a slot named @var{slot_name}.")
#define FUNC_NAME s_scm_slots_exists_p
{
SCM class;
SCM_DEFINE (scm_sys_allocate_instance, "%allocate-instance", 2, 0, 0,
(SCM class, SCM initargs),
- "")
+ "Create a new instance of class @var{class} and initialize it\n"
+ "from the arguments @var{initargs}.")
#define FUNC_NAME s_scm_sys_allocate_instance
{
SCM *m;
SCM_ARG1,
FUNC_NAME);
if (SCM_I_ENTITYP (obj))
- SCM_ENTITY_SETTER (obj) = setter;
+ SCM_SET_ENTITY_SETTER (obj, setter);
else
SCM_OPERATOR_CLASS (obj)->setter = setter;
return SCM_UNSPECIFIED;
scm_make_method_cache (SCM gf)
{
return SCM_LIST5 (SCM_IM_DISPATCH, scm_sym_args, SCM_MAKINUM (1),
- scm_make_vector (SCM_MAKINUM (SCM_INITIAL_MCACHE_SIZE),
- list_of_no_method),
+ scm_c_make_vector (SCM_INITIAL_MCACHE_SIZE,
+ list_of_no_method),
gf);
}
static void
clear_method_cache (SCM gf)
{
- SCM_ENTITY_PROCEDURE (gf) = scm_make_method_cache (gf);
+ SCM cache = scm_make_method_cache (gf);
+ SCM_SET_ENTITY_PROCEDURE (gf, cache);
SCM_SLOT (gf, scm_si_used_by) = SCM_BOOL_F;
}
#define FUNC_NAME s_scm_sys_invalidate_method_cache_x
{
SCM used_by;
- SCM_ASSERT (SCM_STRUCTP (gf) && SCM_PUREGENERICP (gf),
- gf, SCM_ARG1, FUNC_NAME);
+ SCM_ASSERT (SCM_PUREGENERICP (gf), gf, SCM_ARG1, FUNC_NAME);
used_by = SCM_SLOT (gf, scm_si_used_by);
if (SCM_NFALSEP (used_by))
{
scm_i_vector2list (SCM l, int len)
{
int j;
- SCM z = scm_make_vector (SCM_MAKINUM (len), SCM_UNDEFINED);
+ SCM z = scm_c_make_vector (len, SCM_UNDEFINED);
for (j = 0; j < len; j++, l = SCM_CDR (l)) {
SCM_VELTS (z)[j] = SCM_CAR (l);
/* Build the list of arguments types */
if (len >= BUFFSIZE) {
- tmp = scm_make_vector (SCM_MAKINUM (len), SCM_UNDEFINED);
+ tmp = scm_c_make_vector (len, SCM_UNDEFINED);
/* NOTE: Using pointers to malloced memory won't work if we
1. have preemtive threading, and,
2. have a GC which moves objects. */
SCM_ASSYNT (SCM_VECTORP (v), v, SCM_ARG3, s_atdispatch);
x = SCM_CDR (x);
gf = SCM_XEVALCAR (x, env);
- SCM_ASSYNT (SCM_STRUCTP (gf) && SCM_PUREGENERICP (gf),
- gf, SCM_ARG4, s_atdispatch);
+ SCM_ASSYNT (SCM_PUREGENERICP (gf), gf, SCM_ARG4, s_atdispatch);
return SCM_LIST5 (SCM_IM_DISPATCH, args, n, v, gf);
}
#undef FUNC_NAME
SCM_DEFINE (scm_make, "make", 0, 0, 1,
(SCM args),
- "")
+ "Make a new object. @var{args} must contain the class and\n"
+ "all necessary initialization information.")
#define FUNC_NAME s_scm_make
{
SCM class, z;
SCM_ASSERT ((len = scm_ilength (targs)) != -1, targs, SCM_ARG3, FUNC_NAME);
/* Verify that all the arguments of targs are classes and place them in a vector*/
- v = scm_make_vector (SCM_MAKINUM (len), SCM_EOL);
+ v = scm_c_make_vector (len, SCM_EOL);
for (i=0, l=targs; SCM_NNULLP(l); i++, l=SCM_CDR(l)) {
SCM_ASSERT (SCM_CLASSP (SCM_CAR (l)), targs, SCM_ARG3, FUNC_NAME);
&& SCM_FALSEP (scm_apply (scm_goops_lookup_closure,
SCM_LIST2 (name, SCM_BOOL_F),
SCM_EOL)))
- {
- /* Make sure we add the binding in the GOOPS module.
- * This kludge is needed until DEFVAR ceases to use `define-public'
- * or `define-public' ceases to use `current-module'.
- */
- SCM old_module = scm_select_module (scm_module_goops);
- DEFVAR (name, class);
- scm_select_module (old_module);
- }
+ DEFVAR (name, class);
return class;
}
void
scm_add_method (SCM gf, SCM m)
{
- scm_i_eval (SCM_LIST3 (sym_internal_add_method_x, gf, m),
- scm_top_level_env (scm_goops_lookup_closure));
+ scm_eval (SCM_LIST3 (sym_internal_add_method_x, gf, m), scm_module_goops);
}
#ifdef GUILE_DEBUG
SCM_DEFINE (scm_pure_generic_p, "pure-generic?", 1, 0, 0,
(SCM obj),
- "")
+ "Return @code{#t} if @var{obj} is a pure generic.")
#define FUNC_NAME s_scm_pure_generic_p
{
- return SCM_BOOL (SCM_STRUCTP (obj) && SCM_PUREGENERICP (obj));
+ return SCM_BOOL (SCM_PUREGENERICP (obj));
}
#undef FUNC_NAME
SCM_DEFINE (scm_sys_goops_loaded, "%goops-loaded", 0, 0, 0,
(),
- "")
+ "Announce that GOOPS is loaded and perform initialization\n"
+ "on the C level which depends on the loaded GOOPS modules.")
#define FUNC_NAME s_scm_sys_goops_loaded
{
goops_loaded_p = 1;
{
SCM old_module;
scm_module_goops = scm_make_module (scm_read_0str ("(oop goops)"));
- old_module = scm_select_module (scm_module_goops);
+ old_module = scm_set_current_module (scm_module_goops);
scm_goops_lookup_closure = scm_module_lookup_closure (scm_module_goops);
+ /* Not really necessary right now, but who knows...
+ */
+ scm_permanent_object (scm_module_goops);
+ scm_permanent_object (scm_goops_lookup_closure);
+
scm_components = scm_permanent_object (scm_make_weak_key_hash_table
(SCM_MAKINUM (37)));
DEFVAR (name, scm_no_applicable_method);
}
- scm_select_module (old_module);
+ scm_set_current_module (old_module);
}
void
HCoop / bpt / guile.git / blobdiff