-/* Copyright (C) 1998,1999,2000,2001,2002,2003,2004
+/* Copyright (C) 1998,1999,2000,2001,2002,2003,2004,2008
* Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* Erick Gallesio <eg@unice.fr>.
*/
+#ifdef HAVE_CONFIG_H
+# include <config.h>
+#endif
+
#include <stdio.h>
+#include <assert.h>
#include "libguile/_scm.h"
#include "libguile/alist.h"
#define SPEC_OF(x) SCM_SLOT (x, scm_si_specializers)
-#define DEFVAR(v, val) \
-{ scm_eval (scm_list_3 (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_VARIABLE_REF (scm_call_2 (scm_goops_lookup_closure, \
- (v), SCM_BOOL_F)))
-
-/* Fixme: Should use already interned symbols */
-
-#define CALL_GF1(name, a) (scm_call_1 (GETVAR (scm_from_locale_symbol (name)), \
- a))
-#define CALL_GF2(name, a, b) (scm_call_2 (GETVAR (scm_from_locale_symbol (name)), \
- a, b))
-#define CALL_GF3(name, a, b, c) (scm_call_3 (GETVAR (scm_from_locale_symbol (name)), \
- a, b, c))
-#define CALL_GF4(name, a, b, c, d) (scm_call_4 (GETVAR (scm_from_locale_symbol (name)), \
- a, b, c, d))
+/* this file is a mess. in theory, though, we shouldn't have many SCM references
+ -- most of the references should be to vars. */
+
+static SCM var_slot_unbound = SCM_BOOL_F;
+static SCM var_slot_missing = SCM_BOOL_F;
+static SCM var_compute_cpl = SCM_BOOL_F;
+static SCM var_no_applicable_method = SCM_BOOL_F;
+static SCM var_memoize_method_x = SCM_BOOL_F;
+static SCM var_change_class = SCM_BOOL_F;
+
+SCM_SYMBOL (sym_slot_unbound, "slot-unbound");
+SCM_SYMBOL (sym_slot_missing, "slot-missing");
+SCM_SYMBOL (sym_compute_cpl, "compute-cpl");
+SCM_SYMBOL (sym_no_applicable_method, "no-applicable-method");
+SCM_SYMBOL (sym_memoize_method_x, "memoize-method!");
+SCM_SYMBOL (sym_change_class, "change-class");
+
+SCM_VARIABLE (scm_var_make_extended_generic, "make-extended-generic");
+
+
+/* FIXME, exports should come from the scm file only */
+#define DEFVAR(v, val) \
+ { scm_module_define (scm_module_goops, (v), (val)); \
+ scm_module_export (scm_module_goops, scm_list_1 ((v))); \
+ }
+
/* Class redefinition protocol:
static int goops_loaded_p = 0;
static scm_t_rstate *goops_rstate;
-static SCM scm_goops_lookup_closure;
-
/* These variables are filled in by the object system when loaded. */
SCM scm_class_boolean, scm_class_char, scm_class_pair;
SCM scm_class_procedure, scm_class_string, scm_class_symbol;
SCM scm_class_scm;
SCM scm_class_int, scm_class_float, scm_class_double;
-SCM *scm_port_class = 0;
-SCM *scm_smob_class = 0;
+/* Port classes. Allocate 3 times the maximum number of port types so that
+ input ports, output ports, and in/out ports can be stored at different
+ offsets. See `SCM_IN_PCLASS_INDEX' et al. */
+SCM scm_port_class[3 * SCM_I_MAX_PORT_TYPE_COUNT];
+
+/* SMOB classes. */
+SCM scm_smob_class[SCM_I_MAX_SMOB_TYPE_COUNT];
SCM scm_no_applicable_method;
compute_cpl (SCM class)
{
if (goops_loaded_p)
- return CALL_GF1 ("compute-cpl", class);
+ return scm_call_1 (SCM_VARIABLE_REF (var_compute_cpl), class);
else
{
SCM supers = SCM_SLOT (class, scm_si_direct_supers);
{
slot_value = get_slot_value (class, obj, SCM_CAR (get_n_set));
if (SCM_GOOPS_UNBOUNDP (slot_value))
- {
- SCM env = SCM_EXTEND_ENV (SCM_EOL, SCM_EOL, SCM_ENV (tmp));
- set_slot_value (class,
- obj,
- SCM_CAR (get_n_set),
- scm_eval_body (SCM_CLOSURE_BODY (tmp), env));
- }
+ set_slot_value (class,
+ obj,
+ SCM_CAR (get_n_set),
+ scm_call_0 (tmp));
}
}
}
#define FUNC_NAME s_scm_assert_bound
{
if (SCM_GOOPS_UNBOUNDP (value))
- return CALL_GF1 ("slot-unbound", obj);
+ return scm_call_1 (SCM_VARIABLE_REF (var_slot_unbound), obj);
return value;
}
#undef FUNC_NAME
{
SCM value = SCM_SLOT (obj, scm_to_int (index));
if (SCM_GOOPS_UNBOUNDP (value))
- return CALL_GF1 ("slot-unbound", obj);
+ return scm_call_1 (SCM_VARIABLE_REF (var_slot_unbound), obj);
return value;
}
#undef FUNC_NAME
unsigned long int i;
SCM_VALIDATE_INSTANCE (1, obj);
- i = scm_to_unsigned_integer (index, 0, SCM_NUMBER_OF_SLOTS(obj)-1);
+ i = scm_to_unsigned_integer (index, 0,
+ SCM_I_INUM (SCM_SLOT (SCM_CLASS_OF (obj),
+ scm_si_nfields))
+ - 1);
return SCM_SLOT (obj, i);
}
#undef FUNC_NAME
unsigned long int i;
SCM_VALIDATE_INSTANCE (1, obj);
- i = scm_to_unsigned_integer (index, 0, SCM_NUMBER_OF_SLOTS(obj)-1);
+ i = scm_to_unsigned_integer (index, 0,
+ SCM_I_INUM (SCM_SLOT (SCM_CLASS_OF (obj),
+ scm_si_nfields))
+ - 1);
SCM_SET_SLOT (obj, i, value);
static SCM
get_slot_value (SCM class SCM_UNUSED, SCM obj, SCM slotdef)
+#define FUNC_NAME "%get-slot-value"
{
SCM access = SCM_CDDR (slotdef);
/* Two cases here:
* we can just assume fixnums here.
*/
if (SCM_I_INUMP (access))
- return SCM_SLOT (obj, SCM_I_INUM (access));
+ /* Don't poke at the slots directly, because scm_struct_ref handles the
+ access bits for us. */
+ return scm_struct_ref (obj, access);
else
{
/* We must evaluate (apply (car access) (list obj))
code = SCM_CAR (access);
if (!SCM_CLOSUREP (code))
- return SCM_SUBRF (code) (obj);
+ return scm_call_1 (code, obj);
env = SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (code),
scm_list_1 (obj),
SCM_ENV (code));
return scm_eval_body (SCM_CLOSURE_BODY (code), env);
}
}
+#undef FUNC_NAME
static SCM
get_slot_value_using_name (SCM class, SCM obj, SCM slot_name)
if (scm_is_true (slotdef))
return get_slot_value (class, obj, slotdef);
else
- return CALL_GF3 ("slot-missing", class, obj, slot_name);
+ return scm_call_3 (SCM_VARIABLE_REF (var_slot_missing), class, obj, slot_name);
}
static SCM
set_slot_value (SCM class SCM_UNUSED, SCM obj, SCM slotdef, SCM value)
+#define FUNC_NAME "%set-slot-value"
{
SCM access = SCM_CDDR (slotdef);
/* Two cases here:
* we can just assume fixnums here.
*/
if (SCM_I_INUMP (access))
- SCM_SET_SLOT (obj, SCM_I_INUM (access), value);
+ /* obey permissions bits via going through struct-set! */
+ scm_struct_set_x (obj, access, value);
else
{
/* We must evaluate (apply (cadr l) (list obj value))
code = SCM_CADR (access);
if (!SCM_CLOSUREP (code))
- SCM_SUBRF (code) (obj, value);
+ scm_call_2 (code, obj, value);
else
{
env = SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (code),
}
return SCM_UNSPECIFIED;
}
+#undef FUNC_NAME
static SCM
set_slot_value_using_name (SCM class, SCM obj, SCM slot_name, SCM value)
if (scm_is_true (slotdef))
return set_slot_value (class, obj, slotdef, value);
else
- return CALL_GF4 ("slot-missing", class, obj, slot_name, value);
+ return scm_call_4 (SCM_VARIABLE_REF (var_slot_missing), class, obj, slot_name, value);
}
static SCM
res = get_slot_value_using_name (class, obj, slot_name);
if (SCM_GOOPS_UNBOUNDP (res))
- return CALL_GF3 ("slot-unbound", class, obj, slot_name);
+ return scm_call_3 (SCM_VARIABLE_REF (var_slot_unbound), class, obj, slot_name);
return res;
}
#undef FUNC_NAME
res = get_slot_value_using_name (class, obj, slot_name);
if (SCM_GOOPS_UNBOUNDP (res))
- return CALL_GF3 ("slot-unbound", class, obj, slot_name);
+ return scm_call_3 (SCM_VARIABLE_REF (var_slot_unbound), class, obj, slot_name);
return res;
}
#undef FUNC_NAME
wrap_init (SCM class, SCM *m, long n)
{
long i;
+ scm_t_bits slayout = SCM_STRUCT_DATA (class)[scm_vtable_index_layout];
+ const char *layout = scm_i_symbol_chars (SCM_PACK (slayout));
- /* Set all slots to unbound */
+ /* Set all SCM-holding slots to unbound */
for (i = 0; i < n; i++)
- m[i] = SCM_GOOPS_UNBOUND;
+ if (layout[i*2] == 'p')
+ m[i] = SCM_GOOPS_UNBOUND;
+ else
+ m[i] = 0;
return scm_double_cell ((((scm_t_bits) SCM_STRUCT_DATA (class))
| scm_tc3_struct),
{
SCM obj = SCM_PACK ((scm_t_bits) o);
scm_lock_mutex (hell_mutex);
- if (n_hell == hell_size)
+ if (n_hell >= hell_size)
{
- long new_size = 2 * hell_size;
- hell = scm_realloc (hell, new_size);
- hell_size = new_size;
+ hell_size *= 2;
+ hell = scm_realloc (hell, hell_size * sizeof(*hell));
}
hell[n_hell++] = SCM_STRUCT_DATA (obj);
scm_unlock_mutex (hell_mutex);
static SCM
purgatory (void *args)
{
- return scm_apply_0 (GETVAR (scm_sym_change_class),
+ return scm_apply_0 (SCM_VARIABLE_REF (var_change_class),
SCM_PACK ((scm_t_bits) args));
}
gext = scm_call_2 (SCM_VARIABLE_REF (scm_var_make_extended_generic),
gf,
SCM_SNAME (extension));
- *SCM_SUBR_GENERIC (extension) = gext;
+ SCM_SET_SUBR_GENERIC (extension, gext);
}
else
{
{
if (find_method_p)
return SCM_BOOL_F;
- CALL_GF2 ("no-applicable-method", gf, save);
+ scm_call_2 (SCM_VARIABLE_REF (var_no_applicable_method), gf, save);
/* if we are here, it's because no-applicable-method hasn't signaled an error */
return SCM_BOOL_F;
}
SCM cmethod = scm_mcache_lookup_cmethod (x, SCM_CDDR (args));
if (scm_is_true (cmethod))
return cmethod;
- /*fixme* Use scm_apply */
- return CALL_GF3 ("memoize-method!", gf, SCM_CDDR (args), x);
+
+ if (SCM_UNLIKELY (scm_is_false (var_memoize_method_x)))
+ var_memoize_method_x =
+ scm_permanent_object
+ (scm_module_variable (scm_module_goops, sym_memoize_method_x));
+
+ return scm_call_3 (SCM_VARIABLE_REF (var_memoize_method_x), gf, SCM_CDDR (args), x);
}
SCM
SCM_KEYWORD (k_setter, "setter");
SCM_KEYWORD (k_specializers, "specializers");
SCM_KEYWORD (k_procedure, "procedure");
+SCM_KEYWORD (k_formals, "formals");
+SCM_KEYWORD (k_body, "body");
+SCM_KEYWORD (k_make_procedure, "make-procedure");
SCM_KEYWORD (k_dsupers, "dsupers");
SCM_KEYWORD (k_slots, "slots");
SCM_KEYWORD (k_gf, "generic-function");
scm_i_get_keyword (k_procedure,
args,
len - 1,
- SCM_EOL,
+ SCM_BOOL_F,
FUNC_NAME));
SCM_SET_SLOT (z, scm_si_code_table, SCM_EOL);
+ SCM_SET_SLOT (z, scm_si_formals,
+ scm_i_get_keyword (k_formals,
+ args,
+ len - 1,
+ SCM_EOL,
+ FUNC_NAME));
+ SCM_SET_SLOT (z, scm_si_body,
+ scm_i_get_keyword (k_body,
+ args,
+ len - 1,
+ SCM_EOL,
+ FUNC_NAME));
+ SCM_SET_SLOT (z, scm_si_make_procedure,
+ scm_i_get_keyword (k_make_procedure,
+ args,
+ len - 1,
+ SCM_BOOL_F,
+ FUNC_NAME));
}
else
{
create_standard_classes (void)
{
SCM slots;
- SCM method_slots = scm_list_4 (scm_from_locale_symbol ("generic-function"),
+ SCM method_slots = scm_list_n (scm_from_locale_symbol ("generic-function"),
scm_from_locale_symbol ("specializers"),
sym_procedure,
- scm_from_locale_symbol ("code-table"));
+ scm_from_locale_symbol ("code-table"),
+ scm_from_locale_symbol ("formals"),
+ scm_from_locale_symbol ("body"),
+ scm_from_locale_symbol ("make-procedure"),
+ SCM_UNDEFINED);
SCM amethod_slots = scm_list_1 (scm_list_3 (scm_from_locale_symbol ("slot-definition"),
k_init_keyword,
k_slot_definition));
/* Only define name if doesn't already exist. */
if (!SCM_GOOPS_UNBOUNDP (name)
- && scm_is_false (scm_call_2 (scm_goops_lookup_closure, name, SCM_BOOL_F)))
+ && scm_is_false (scm_module_variable (scm_module_goops, name)))
DEFVAR (name, class);
return class;
}
{
long i;
- scm_smob_class = (SCM *) scm_malloc (255 * sizeof (SCM));
- for (i = 0; i < 255; ++i)
+ for (i = 0; i < SCM_I_MAX_SMOB_TYPE_COUNT; ++i)
scm_smob_class[i] = 0;
scm_smob_class[SCM_TC2SMOBNUM (scm_tc16_keyword)] = scm_class_keyword;
{
long i;
- scm_port_class = (SCM *) scm_malloc (3 * 256 * sizeof (SCM));
- for (i = 0; i < 3 * 256; ++i)
- scm_port_class[i] = 0;
-
for (i = 0; i < scm_numptob; ++i)
scm_make_port_classes (i, SCM_PTOBNAME (i));
}
scm_list_1 (slot))));
{
SCM n = SCM_SLOT (class, scm_si_nfields);
- SCM gns = scm_list_n (name, SCM_BOOL_F, get, set, n, scm_from_int (1));
+ SCM gns = scm_list_n (name, SCM_BOOL_F, get, set, n, scm_from_int (1),
+ SCM_UNDEFINED);
SCM_SET_SLOT (class, scm_si_getters_n_setters,
scm_append_x (scm_list_2 (SCM_SLOT (class, scm_si_getters_n_setters),
scm_list_1 (gns))));
{
goops_loaded_p = 1;
var_compute_applicable_methods =
- scm_sym2var (sym_compute_applicable_methods, scm_goops_lookup_closure,
- SCM_BOOL_F);
+ scm_permanent_object
+ (scm_module_variable (scm_module_goops, sym_compute_applicable_methods));
+ var_slot_unbound =
+ scm_permanent_object
+ (scm_module_variable (scm_module_goops, sym_slot_unbound));
+ var_slot_missing =
+ scm_permanent_object
+ (scm_module_variable (scm_module_goops, sym_slot_missing));
+ var_compute_cpl =
+ scm_permanent_object
+ (scm_module_variable (scm_module_goops, sym_compute_cpl));
+ var_no_applicable_method =
+ scm_permanent_object
+ (scm_module_variable (scm_module_goops, sym_no_applicable_method));
+ var_change_class =
+ scm_permanent_object
+ (scm_module_variable (scm_module_goops, sym_change_class));
setup_extended_primitive_generics ();
return SCM_UNSPECIFIED;
}
scm_init_goops_builtins (void)
{
scm_module_goops = scm_current_module ();
- 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_from_int (37)));
list_of_no_method = scm_permanent_object (scm_list_1 (sym_no_method));
- hell = scm_malloc (hell_size);
+ hell = scm_calloc (hell_size * sizeof (*hell));
hell_mutex = scm_permanent_object (scm_make_mutex ());
create_basic_classes ();
HCoop / bpt / guile.git / blobdiff