-/* Copyright (C) 1998,1999,2000,2001,2002,2003,2004,2008,2009,2010,2011,2012
+/* Copyright (C) 1998,1999,2000,2001,2002,2003,2004,2008,2009,2010,2011,2012,2013,2014,2015
* Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
static SCM class_fluid;
static SCM class_dynamic_state;
static SCM class_frame;
-static SCM class_objcode;
-static SCM class_vm;
static SCM class_vm_cont;
static SCM class_bytevector;
static SCM class_uvec;
return class_dynamic_state;
case scm_tc7_frame:
return class_frame;
- case scm_tc7_objcode:
- return class_objcode;
- case scm_tc7_vm:
- return class_vm;
+ case scm_tc7_keyword:
+ return scm_class_keyword;
case scm_tc7_vm_cont:
return class_vm_cont;
case scm_tc7_bytevector:
else
return scm_class_procedure;
- case scm_tc7_rtl_program:
- return scm_class_procedure;
-
case scm_tc7_smob:
{
scm_t_bits type = SCM_TYP16 (x);
get_n_set = SCM_CDR (get_n_set), slots = SCM_CDR (slots))
{
SCM slot_name = SCM_CAR (slots);
- SCM slot_value = SCM_PACK (0);
+ SCM slot_value = SCM_GOOPS_UNBOUND;
if (!scm_is_null (SCM_CDR (slot_name)))
{
slot_value = scm_i_get_keyword (tmp,
initargs,
n_initargs,
- SCM_PACK (0),
+ SCM_GOOPS_UNBOUND,
FUNC_NAME);
}
}
- if (SCM_UNPACK (slot_value))
+ if (!SCM_GOOPS_UNBOUNDP (slot_value))
/* set slot to provided value */
set_slot_value (class, obj, SCM_CAR (get_n_set), slot_value);
else
/* set slot to its :init-form if it exists */
tmp = SCM_CADAR (get_n_set);
if (scm_is_true (tmp))
- {
- slot_value = get_slot_value (class, obj, SCM_CAR (get_n_set));
- if (SCM_GOOPS_UNBOUNDP (slot_value))
- set_slot_value (class,
- obj,
- SCM_CAR (get_n_set),
- scm_call_0 (tmp));
- }
+ set_slot_value (class,
+ obj,
+ SCM_CAR (get_n_set),
+ scm_call_0 (tmp));
}
}
SCM_GLOBAL_SYMBOL (scm_sym_args, "args");
-
SCM_SYMBOL (sym_delayed_compile, "delayed-compile");
+
+static SCM delayed_compile_var;
+
+static void
+init_delayed_compile_var (void)
+{
+ delayed_compile_var
+ = scm_c_private_lookup ("oop goops dispatch", "delayed-compile");
+}
+
static SCM
make_dispatch_procedure (SCM gf)
{
- static SCM var = SCM_BOOL_F;
- if (scm_is_false (var))
- var = scm_module_variable (scm_c_resolve_module ("oop goops dispatch"),
- sym_delayed_compile);
- return scm_call_1 (SCM_VARIABLE_REF (var), gf);
+ static scm_i_pthread_once_t once = SCM_I_PTHREAD_ONCE_INIT;
+ scm_i_pthread_once (&once, init_delayed_compile_var);
+
+ return scm_call_1 (scm_variable_ref (delayed_compile_var), gf);
}
static void
*
******************************************************************************/
-static int
-applicablep (SCM actual, SCM formal)
-{
- /* We already know that the cpl is well formed. */
- return scm_is_true (scm_c_memq (formal, SCM_SLOT (actual, scm_si_cpl)));
-}
-
static int
more_specificp (SCM m1, SCM m2, SCM const *targs)
{
return 0; /* should not occur! */
}
-#define BUFFSIZE 32 /* big enough for most uses */
-
-static SCM
-scm_i_vector2list (SCM l, long len)
-{
- long j;
- SCM z = scm_c_make_vector (len, SCM_UNDEFINED);
-
- for (j = 0; j < len; j++, l = SCM_CDR (l)) {
- SCM_SIMPLE_VECTOR_SET (z, j, SCM_CAR (l));
- }
- return z;
-}
-
-static SCM
-sort_applicable_methods (SCM method_list, long size, SCM const *targs)
-{
- long i, j, incr;
- SCM *v, vector = SCM_EOL;
- SCM buffer[BUFFSIZE];
- SCM save = method_list;
- scm_t_array_handle handle;
-
- /* For reasonably sized method_lists we can try to avoid all the
- * consing and reorder the list in place...
- * This idea is due to David McClain <Dave_McClain@msn.com>
- */
- if (size <= BUFFSIZE)
- {
- for (i = 0; i < size; i++)
- {
- buffer[i] = SCM_CAR (method_list);
- method_list = SCM_CDR (method_list);
- }
- v = buffer;
- }
- else
- {
- /* Too many elements in method_list to keep everything locally */
- vector = scm_i_vector2list (save, size);
- v = scm_vector_writable_elements (vector, &handle, NULL, NULL);
- }
-
- /* Use a simple shell sort since it is generally faster than qsort on
- * small vectors (which is probably mostly the case when we have to
- * sort a list of applicable methods).
- */
- for (incr = size / 2; incr; incr /= 2)
- {
- for (i = incr; i < size; i++)
- {
- for (j = i - incr; j >= 0; j -= incr)
- {
- if (more_specificp (v[j], v[j+incr], targs))
- break;
- else
- {
- SCM tmp = v[j + incr];
- v[j + incr] = v[j];
- v[j] = tmp;
- }
- }
- }
- }
-
- if (size <= BUFFSIZE)
- {
- /* We did it in locally, so restore the original list (reordered) in-place */
- for (i = 0, method_list = save; i < size; i++, v++)
- {
- SCM_SETCAR (method_list, *v);
- method_list = SCM_CDR (method_list);
- }
- return save;
- }
-
- /* If we are here, that's that we did it the hard way... */
- scm_array_handle_release (&handle);
- return scm_vector_to_list (vector);
-}
-
-SCM
-scm_compute_applicable_methods (SCM gf, SCM args, long len, int find_method_p)
-{
- register long i;
- long count = 0;
- SCM l, fl, applicable = SCM_EOL;
- SCM save = args;
- SCM buffer[BUFFSIZE];
- SCM const *types;
- SCM *p;
- SCM tmp = SCM_EOL;
- scm_t_array_handle handle;
-
- /* Build the list of arguments types */
- if (len >= BUFFSIZE)
- {
- tmp = scm_c_make_vector (len, SCM_UNDEFINED);
- types = p = scm_vector_writable_elements (tmp, &handle, NULL, NULL);
-
- /*
- note that we don't have to work to reset the generation
- count. TMP is a new vector anyway, and it is found
- conservatively.
- */
- }
- else
- types = p = buffer;
-
- for ( ; !scm_is_null (args); args = SCM_CDR (args))
- *p++ = scm_class_of (SCM_CAR (args));
-
- /* Build a list of all applicable methods */
- for (l = scm_generic_function_methods (gf); !scm_is_null (l); l = SCM_CDR (l))
- {
- fl = SPEC_OF (SCM_CAR (l));
- for (i = 0; ; i++, fl = SCM_CDR (fl))
- {
- if (SCM_INSTANCEP (fl)
- /* We have a dotted argument list */
- || (i >= len && scm_is_null (fl)))
- { /* both list exhausted */
- applicable = scm_cons (SCM_CAR (l), applicable);
- count += 1;
- break;
- }
- if (i >= len
- || scm_is_null (fl)
- || !applicablep (types[i], SCM_CAR (fl)))
- break;
- }
- }
-
- if (len >= BUFFSIZE)
- scm_array_handle_release (&handle);
-
- if (count == 0)
- {
- if (find_method_p)
- return SCM_BOOL_F;
- 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;
- }
-
- return (count == 1
- ? applicable
- : sort_applicable_methods (applicable, count, types));
-}
-
-#if 0
-SCM_PROC (s_sys_compute_applicable_methods, "%compute-applicable-methods", 2, 0, 0, scm_sys_compute_applicable_methods);
-#endif
-
-static const char s_sys_compute_applicable_methods[] = "%compute-applicable-methods";
-
-SCM
-scm_sys_compute_applicable_methods (SCM gf, SCM args)
-#define FUNC_NAME s_sys_compute_applicable_methods
-{
- long n;
- SCM_VALIDATE_GENERIC (1, gf);
- n = scm_ilength (args);
- SCM_ASSERT (n >= 0, args, SCM_ARG2, FUNC_NAME);
- return scm_compute_applicable_methods (gf, args, n, 1);
-}
-#undef FUNC_NAME
-
-SCM_SYMBOL (sym_compute_applicable_methods, "compute-applicable-methods");
-SCM_VARIABLE_INIT (var_compute_applicable_methods, "compute-applicable-methods",
- scm_c_define_gsubr (s_sys_compute_applicable_methods, 2, 0, 0,
- scm_sys_compute_applicable_methods));
-
/******************************************************************************
*
* A simple make (which will be redefined later in Scheme)
}
#undef FUNC_NAME
-SCM_DEFINE (scm_find_method, "find-method", 0, 0, 1,
- (SCM l),
- "")
-#define FUNC_NAME s_scm_find_method
-{
- SCM gf;
- long len = scm_ilength (l);
-
- if (len == 0)
- SCM_WRONG_NUM_ARGS ();
-
- gf = SCM_CAR(l); l = SCM_CDR(l);
- SCM_VALIDATE_GENERIC (1, gf);
- if (scm_is_null (SCM_SLOT (gf, scm_si_methods)))
- SCM_MISC_ERROR ("no methods for generic ~S", scm_list_1 (gf));
-
- return scm_compute_applicable_methods (gf, l, len - 1, 1);
-}
-#undef FUNC_NAME
-
SCM_DEFINE (scm_sys_method_more_specific_p, "%method-more-specific?", 3, 0, 0,
(SCM m1, SCM m2, SCM targs),
"Return true if method @var{m1} is more specific than @var{m2} "
scm_class_class, scm_class_top, SCM_EOL);
make_stdcls (&class_frame, "<frame>",
scm_class_class, scm_class_top, SCM_EOL);
- make_stdcls (&class_objcode, "<objcode>",
- scm_class_class, scm_class_top, SCM_EOL);
- make_stdcls (&class_vm, "<vm>",
- scm_class_class, scm_class_top, SCM_EOL);
make_stdcls (&class_vm_cont, "<vm-continuation>",
scm_class_class, scm_class_top, SCM_EOL);
make_stdcls (&class_bytevector, "<bytevector>",
for (i = 0; i < SCM_I_MAX_SMOB_TYPE_COUNT; ++i)
scm_smob_class[i] = SCM_BOOL_F;
- scm_smob_class[SCM_TC2SMOBNUM (scm_tc16_keyword)] = scm_class_keyword;
-
for (i = 0; i < scm_numsmob; ++i)
if (scm_is_false (scm_smob_class[i]))
scm_smob_class[i] = scm_make_extended_class (SCM_SMOBNAME (i),
#define FUNC_NAME s_scm_sys_goops_loaded
{
goops_loaded_p = 1;
- var_compute_applicable_methods =
- scm_module_variable (scm_module_goops, sym_compute_applicable_methods);
var_slot_unbound =
scm_module_variable (scm_module_goops, sym_slot_unbound);
var_slot_missing =
HCoop / bpt / guile.git / blobdiff