-/* Copyright (C) 1998,1999,2000,2001,2002,2003,2004,2008,2009
+/* Copyright (C) 1998,1999,2000,2001,2002,2003,2004,2008,2009,2010,2011,2012,2014,2015
* Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
#endif
#include <stdio.h>
-#include <assert.h>
#include "libguile/_scm.h"
#include "libguile/alist.h"
#include "libguile/dynl.h"
#include "libguile/dynwind.h"
#include "libguile/eval.h"
+#include "libguile/gsubr.h"
#include "libguile/hashtab.h"
#include "libguile/keywords.h"
#include "libguile/macros.h"
#define NXT_MTHD_ARGS(m) (SCM_VELTS (m)[2])
#define SCM_GOOPS_UNBOUND SCM_UNBOUND
-#define SCM_GOOPS_UNBOUNDP(x) ((x) == SCM_GOOPS_UNBOUND)
+#define SCM_GOOPS_UNBOUNDP(x) (scm_is_eq (x, SCM_GOOPS_UNBOUND))
static int goops_loaded_p = 0;
static scm_t_rstate *goops_rstate;
SCM scm_class_scm;
SCM scm_class_int, scm_class_float, scm_class_double;
+static SCM class_foreign;
static SCM class_hashtable;
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;
+static SCM class_array;
+static SCM class_bitvector;
+
+static SCM vtable_class_map = SCM_BOOL_F;
+static scm_i_pthread_mutex_t vtable_class_map_lock = SCM_I_PTHREAD_MUTEX_INITIALIZER;
/* 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
static SCM scm_make_extended_class_from_symbol (SCM type_name_sym,
int applicablep);
+
+SCM
+scm_i_define_class_for_vtable (SCM vtable)
+{
+ SCM class;
+
+ scm_i_pthread_mutex_lock (&vtable_class_map_lock);
+
+ if (scm_is_false (vtable_class_map))
+ vtable_class_map = scm_make_weak_key_hash_table (SCM_UNDEFINED);
+
+ if (scm_is_false (scm_struct_vtable_p (vtable)))
+ abort ();
+
+ class = scm_hashq_ref (vtable_class_map, vtable, SCM_BOOL_F);
+
+ scm_i_pthread_mutex_unlock (&vtable_class_map_lock);
+
+ if (scm_is_false (class))
+ {
+ if (SCM_UNPACK (scm_class_class))
+ {
+ SCM name = SCM_VTABLE_NAME (vtable);
+ if (!scm_is_symbol (name))
+ name = scm_string_to_symbol (scm_nullstr);
+
+ class = scm_make_extended_class_from_symbol
+ (name, SCM_VTABLE_FLAG_IS_SET (vtable, SCM_VTABLE_FLAG_APPLICABLE));
+ }
+ else
+ /* `create_struct_classes' will fill this in later. */
+ class = SCM_BOOL_F;
+
+ /* Don't worry about races. This only happens when creating a
+ vtable, which happens by definition in one thread. */
+ scm_i_pthread_mutex_lock (&vtable_class_map_lock);
+ scm_hashq_set_x (vtable_class_map, vtable, class);
+ scm_i_pthread_mutex_unlock (&vtable_class_map_lock);
+ }
+
+ return class;
+}
+
/* This function is used for efficient type dispatch. */
SCM_DEFINE (scm_class_of, "class-of", 1, 0, 0,
(SCM x),
case scm_tc7_vector:
case scm_tc7_wvect:
return scm_class_vector;
+ case scm_tc7_pointer:
+ return class_foreign;
case scm_tc7_hashtable:
return class_hashtable;
case scm_tc7_fluid:
return class_fluid;
case scm_tc7_dynamic_state:
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_vm_cont:
+ return class_vm_cont;
+ case scm_tc7_bytevector:
+ if (SCM_BYTEVECTOR_ELEMENT_TYPE (x) == SCM_ARRAY_ELEMENT_TYPE_VU8)
+ return class_bytevector;
+ else
+ return class_uvec;
+ case scm_tc7_array:
+ return class_array;
+ case scm_tc7_bitvector:
+ return class_bitvector;
case scm_tc7_string:
return scm_class_string;
case scm_tc7_number:
case scm_tc16_fraction:
return scm_class_fraction;
}
- case scm_tc7_gsubr:
- if (SCM_SUBR_GENERIC (x) && *SCM_SUBR_GENERIC (x))
+ case scm_tc7_program:
+ if (SCM_PROGRAM_IS_PRIMITIVE_GENERIC (x)
+ && SCM_UNPACK (*SCM_SUBR_GENERIC (x)))
return scm_class_primitive_generic;
else
return scm_class_procedure;
- case scm_tc7_program:
- return scm_class_procedure;
case scm_tc7_smob:
{
return SCM_CLASS_OF (x);
}
else
- {
- /* ordinary struct */
- SCM handle = scm_struct_create_handle (SCM_STRUCT_VTABLE (x));
- if (scm_is_true (SCM_STRUCT_TABLE_CLASS (SCM_CDR (handle))))
- return SCM_STRUCT_TABLE_CLASS (SCM_CDR (handle));
- else
- {
- SCM class, name;
-
- name = SCM_STRUCT_TABLE_NAME (SCM_CDR (handle));
- if (!scm_is_symbol (name))
- name = scm_string_to_symbol (scm_nullstr);
-
- class =
- scm_make_extended_class_from_symbol (name,
- SCM_STRUCT_APPLICABLE_P (x));
- SCM_SET_STRUCT_TABLE_CLASS (SCM_CDR (handle), class);
- return class;
- }
- }
+ return scm_i_define_class_for_vtable (SCM_CLASS_OF (x));
default:
if (scm_is_pair (x))
return scm_class_pair;
SCM res = scm_cons (proc (SCM_CAR (ls)), SCM_EOL);
SCM h = res;
ls = SCM_CDR (ls);
- while (!scm_is_null (ls))
+ while (scm_is_pair (ls))
{
SCM_SETCDR (h, scm_cons (proc (SCM_CAR (ls)), SCM_EOL));
h = SCM_CDR (h);
filter_cpl (SCM ls)
{
SCM res = SCM_EOL;
- while (!scm_is_null (ls))
+ while (scm_is_pair (ls))
{
SCM el = SCM_CAR (ls);
if (scm_is_false (scm_c_memq (el, res)))
{
SCM tmp;
- if (scm_is_null (l))
+ if (!scm_is_pair (l))
return res;
tmp = SCM_CAAR (l);
return remove_duplicate_slots (SCM_CDR (l), res, slots_already_seen);
}
+static void
+check_cpl (SCM slots, SCM bslots)
+{
+ for (; scm_is_pair (bslots); bslots = SCM_CDR (bslots))
+ if (scm_is_true (scm_assq (SCM_CAAR (bslots), slots)))
+ scm_misc_error ("init-object", "a predefined <class> inherited "
+ "field cannot be redefined", SCM_EOL);
+}
+
+static SCM
+build_class_class_slots (void);
+
static SCM
build_slots_list (SCM dslots, SCM cpl)
{
- register SCM res = dslots;
+ SCM bslots, class_slots;
+ int classp;
+ SCM res = dslots;
+
+ class_slots = SCM_EOL;
+ classp = scm_is_true (scm_memq (scm_class_class, cpl));
+
+ if (classp)
+ {
+ bslots = build_class_class_slots ();
+ check_cpl (res, bslots);
+ }
+ else
+ bslots = SCM_EOL;
+
+ if (scm_is_pair (cpl))
+ {
+ for (cpl = SCM_CDR (cpl); scm_is_pair (cpl); cpl = SCM_CDR (cpl))
+ {
+ SCM new_slots = SCM_SLOT (SCM_CAR (cpl),
+ scm_si_direct_slots);
+ if (classp)
+ {
+ if (!scm_is_eq (SCM_CAR (cpl), scm_class_class))
+ check_cpl (new_slots, bslots);
+ else
+ {
+ /* Move class slots to the head of the list. */
+ class_slots = new_slots;
+ continue;
+ }
+ }
+ res = scm_append (scm_list_2 (new_slots, res));
+ }
+ }
+ else
+ scm_misc_error ("%compute-slots", "malformed cpl argument in "
+ "build_slots_list", SCM_EOL);
- for (cpl = SCM_CDR (cpl); !scm_is_null (cpl); cpl = SCM_CDR (cpl))
- res = scm_append (scm_list_2 (SCM_SLOT (SCM_CAR (cpl),
- scm_si_direct_slots),
- res));
+ /* make sure to add the <class> slots to the head of the list */
+ if (classp)
+ res = scm_append (scm_list_2 (class_slots, res));
/* res contains a list of slots. Remove slots which appears more than once */
return remove_duplicate_slots (scm_reverse (res), SCM_EOL, SCM_EOL);
SCM orig = ls;
while (!scm_is_null (ls))
{
+ if (!scm_is_pair (ls))
+ scm_misc_error ("%compute-slots", "malformed ls argument in "
+ "maplist", SCM_EOL);
if (!scm_is_pair (SCM_CAR (ls)))
- SCM_SETCAR (ls, scm_cons (SCM_CAR (ls), SCM_EOL));
+ SCM_SETCAR (ls, scm_cons (SCM_CAR (ls), SCM_EOL));
ls = SCM_CDR (ls);
}
return orig;
SCM options = SCM_CDAR (slots);
if (!scm_is_null (options))
{
- init = scm_get_keyword (k_init_value, options, 0);
- if (init)
+ init = scm_get_keyword (k_init_value, options, SCM_PACK (0));
+ if (SCM_UNPACK (init))
{
init = scm_primitive_eval (scm_list_3 (scm_sym_lambda,
SCM_EOL,
get_n_set = SCM_CDR (get_n_set), slots = SCM_CDR (slots))
{
SCM slot_name = SCM_CAR (slots);
- SCM slot_value = 0;
+ SCM slot_value = SCM_GOOPS_UNBOUND;
if (!scm_is_null (SCM_CDR (slot_name)))
{
tmp = scm_i_get_keyword (k_init_keyword,
SCM_CDR (slot_name),
n,
- 0,
+ SCM_PACK (0),
FUNC_NAME);
slot_name = SCM_CAR (slot_name);
- if (tmp)
+ if (SCM_UNPACK (tmp))
{
/* an initarg was provided for this slot */
if (!scm_is_keyword (tmp))
slot_value = scm_i_get_keyword (tmp,
initargs,
n_initargs,
- 0,
+ SCM_GOOPS_UNBOUND,
FUNC_NAME);
}
}
- if (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_MISC_ERROR ("class object doesn't have enough fields: ~S",
scm_list_1 (nfields));
- layout = scm_i_make_string (n, &s);
+ layout = scm_i_make_string (n, &s, 0);
i = 0;
while (scm_is_pair (getters_n_setters))
{
static SCM
-build_class_class_slots ()
+build_class_class_slots (void)
{
/* has to be kept in sync with SCM_VTABLE_BASE_LAYOUT and
SCM_CLASS_CLASS_LAYOUT */
/**** <class> ****/
SCM cs = scm_from_locale_string (SCM_CLASS_CLASS_LAYOUT);
- SCM name = scm_from_locale_symbol ("<class>");
- scm_class_class = scm_make_vtable_vtable (cs, SCM_INUM0, SCM_EOL);
+ SCM name = scm_from_latin1_symbol ("<class>");
+ scm_class_class = scm_i_make_vtable_vtable (cs);
SCM_SET_CLASS_FLAGS (scm_class_class, (SCM_CLASSF_GOOPS_OR_VALID
| SCM_CLASSF_METACLASS));
DEFVAR(name, scm_class_class);
/**** <top> ****/
- name = scm_from_locale_symbol ("<top>");
+ name = scm_from_latin1_symbol ("<top>");
scm_class_top = scm_basic_make_class (scm_class_class, name,
SCM_EOL, SCM_EOL);
DEFVAR(name, scm_class_top);
/**** <object> ****/
- name = scm_from_locale_symbol ("<object>");
+ name = scm_from_latin1_symbol ("<object>");
scm_class_object = scm_basic_make_class (scm_class_class, name,
scm_list_1 (scm_class_top), SCM_EOL);
#define FUNC_NAME s_scm_method_generic_function
{
SCM_VALIDATE_METHOD (1, obj);
- return scm_slot_ref (obj, scm_from_locale_symbol ("generic-function"));
+ return scm_slot_ref (obj, scm_from_latin1_symbol ("generic-function"));
}
#undef FUNC_NAME
#define FUNC_NAME s_scm_method_specializers
{
SCM_VALIDATE_METHOD (1, obj);
- return scm_slot_ref (obj, scm_from_locale_symbol ("specializers"));
+ return scm_slot_ref (obj, scm_from_latin1_symbol ("specializers"));
}
#undef FUNC_NAME
"Return the slot value with index @var{index} from @var{obj}.")
#define FUNC_NAME s_scm_sys_fast_slot_ref
{
- unsigned long int i;
+ scm_t_bits i;
SCM_VALIDATE_INSTANCE (1, obj);
i = scm_to_unsigned_integer (index, 0,
"@var{value}.")
#define FUNC_NAME s_scm_sys_fast_slot_set_x
{
- unsigned long int i;
+ scm_t_bits i;
SCM_VALIDATE_INSTANCE (1, obj);
i = scm_to_unsigned_integer (index, 0,
{
register SCM slots = SCM_SLOT (class, scm_si_getters_n_setters);
for (; !scm_is_null (slots); slots = SCM_CDR (slots))
- if (SCM_CAAR (slots) == slot_name)
+ if (scm_is_eq (SCM_CAAR (slots), slot_name))
return SCM_CAR (slots);
return SCM_BOOL_F;
}
#define FUNC_NAME s_scm_sys_allocate_instance
{
SCM obj;
- long n;
- long i;
+ scm_t_signed_bits n, i;
SCM layout;
SCM_VALIDATE_CLASS (1, class);
static void
go_to_hell (void *o)
{
- SCM obj = SCM_PACK ((scm_t_bits) o);
+ SCM obj = *(SCM*)o;
scm_lock_mutex (hell_mutex);
if (n_hell >= hell_size)
{
static void
go_to_heaven (void *o)
{
+ SCM obj = *(SCM*)o;
scm_lock_mutex (hell_mutex);
- hell[burnin (SCM_PACK ((scm_t_bits) o))] = hell[--n_hell];
+ hell[burnin (obj)] = hell[--n_hell];
scm_unlock_mutex (hell_mutex);
}
SCM_SYMBOL (scm_sym_change_class, "change-class");
static SCM
-purgatory (void *args)
+purgatory (SCM obj, SCM new_class)
{
- return scm_apply_0 (SCM_VARIABLE_REF (var_change_class),
- SCM_PACK ((scm_t_bits) args));
+ return scm_call_2 (SCM_VARIABLE_REF (var_change_class), obj, new_class);
}
/* This function calls the generic function change-class for all
scm_change_object_class (SCM obj, SCM old_class SCM_UNUSED, SCM new_class)
{
if (!burnin (obj))
- scm_internal_dynamic_wind (go_to_hell, purgatory, go_to_heaven,
- (void *) SCM_UNPACK (scm_list_2 (obj, new_class)),
- (void *) SCM_UNPACK (obj));
+ {
+ scm_dynwind_begin (SCM_F_DYNWIND_REWINDABLE);
+ scm_dynwind_rewind_handler (go_to_hell, &obj, SCM_F_WIND_EXPLICITLY);
+ scm_dynwind_unwind_handler (go_to_heaven, &obj, SCM_F_WIND_EXPLICITLY);
+ purgatory (obj, new_class);
+ scm_dynwind_end ();
+ }
}
/******************************************************************************
return scm_call_3 (SCM_STRUCT_PROCEDURE (gf), a1, a2, a3);
}
-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 (var == SCM_BOOL_F)
- 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
{
SCM_ASSERT (scm_is_true (scm_procedure_p (proc)),
proc, SCM_ARG1, FUNC_NAME);
- return (scm_subr_p (proc) && SCM_SUBR_GENERIC (proc)
- ? SCM_BOOL_T
- : SCM_BOOL_F);
+ return (SCM_PRIMITIVE_GENERIC_P (proc) ? SCM_BOOL_T : SCM_BOOL_F);
}
#undef FUNC_NAME
while (!scm_is_null (subrs))
{
SCM subr = SCM_CAR (subrs);
- SCM_ASSERT (scm_subr_p (subr) && SCM_SUBR_GENERIC (subr),
- subr, SCM_ARGn, FUNC_NAME);
- *SCM_SUBR_GENERIC (subr)
- = scm_make (scm_list_3 (scm_class_generic,
- k_name,
- SCM_SUBR_NAME (subr)));
+ SCM_ASSERT (SCM_PRIMITIVE_GENERIC_P (subr), subr, SCM_ARGn, FUNC_NAME);
+ SCM_SET_SUBR_GENERIC (subr,
+ scm_make (scm_list_3 (scm_class_generic,
+ k_name,
+ SCM_SUBR_NAME (subr))));
subrs = SCM_CDR (subrs);
}
return SCM_UNSPECIFIED;
"")
#define FUNC_NAME s_scm_set_primitive_generic_x
{
- SCM_ASSERT (scm_subr_p (subr) && SCM_SUBR_GENERIC (subr),
- subr, SCM_ARG1, FUNC_NAME);
+ SCM_ASSERT (SCM_PRIMITIVE_GENERIC_P (subr), subr, SCM_ARG1, FUNC_NAME);
SCM_ASSERT (SCM_PUREGENERICP (generic), generic, SCM_ARG2, FUNC_NAME);
- *SCM_SUBR_GENERIC (subr) = generic;
+ SCM_SET_SUBR_GENERIC (subr, generic);
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
"")
#define FUNC_NAME s_scm_primitive_generic_generic
{
- if (scm_subr_p (subr) && SCM_SUBR_GENERIC (subr))
+ if (SCM_PRIMITIVE_GENERIC_P (subr))
{
- if (!*SCM_SUBR_GENERIC (subr))
+ if (!SCM_UNPACK (*SCM_SUBR_GENERIC (subr)))
scm_enable_primitive_generic_x (scm_list_1 (subr));
return *SCM_SUBR_GENERIC (subr);
}
if (goops_loaded_p)
{
SCM gf, gext;
- if (!*SCM_SUBR_GENERIC (extended))
+ if (!SCM_UNPACK (*SCM_SUBR_GENERIC (extended)))
scm_enable_primitive_generic_x (scm_list_1 (extended));
gf = *SCM_SUBR_GENERIC (extended);
gext = scm_call_2 (SCM_VARIABLE_REF (scm_var_make_extended_generic),
* extensions in the extensions list. O(N^2) algorithm, but
* extensions of primitive generics are rare.
*/
- while (*loc && extension != (*loc)->extended)
+ while (*loc && !scm_is_eq (extension, (*loc)->extended))
loc = &(*loc)->next;
e->next = *loc;
e->extended = extended;
for (i=0, s1=SPEC_OF(m1), s2=SPEC_OF(m2); ; i++, s1=SCM_CDR(s1), s2=SCM_CDR(s2)) {
if (scm_is_null(s1)) return 1;
if (scm_is_null(s2)) return 0;
- if (SCM_CAR(s1) != SCM_CAR(s2)) {
+ if (!scm_is_eq (SCM_CAR(s1), SCM_CAR(s2))) {
register SCM l, cs1 = SCM_CAR(s1), cs2 = SCM_CAR(s2);
for (l = SCM_SLOT (targs[i], scm_si_cpl); ; l = SCM_CDR(l)) {
- if (cs1 == SCM_CAR(l))
+ if (scm_is_eq (cs1, SCM_CAR (l)))
return 1;
- if (cs2 == SCM_CAR(l))
+ if (scm_is_eq (cs2, SCM_CAR (l)))
return 0;
}
return 0;/* should not occur! */
return scm_vector_to_list (vector);
}
+static int
+is_accessor_method (SCM method) {
+ return SCM_IS_A_P (method, scm_class_accessor_method);
+}
+
SCM
scm_compute_applicable_methods (SCM gf, SCM args, long len, int find_method_p)
{
for (l = scm_generic_function_methods (gf); !scm_is_null (l); l = SCM_CDR (l))
{
fl = SPEC_OF (SCM_CAR (l));
+ /* Only accept accessors which match exactly in first arg. */
+ if ((scm_is_null (fl) || types[0] != SCM_CAR (fl))
+ && is_accessor_method (SCM_CAR (l)))
+ continue;
for (i = 0; ; i++, fl = SCM_CDR (fl))
{
if (SCM_INSTANCEP (fl)
#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));
+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));
/******************************************************************************
*
class = SCM_CAR(args);
args = SCM_CDR(args);
- if (class == scm_class_generic || class == scm_class_accessor)
+ if (scm_is_eq (class, scm_class_generic)
+ || scm_is_eq (class, scm_class_accessor))
{
z = scm_make_struct (class, SCM_INUM0,
scm_list_4 (SCM_BOOL_F,
args,
SCM_BOOL_F));
clear_method_cache (z);
- if (class == scm_class_accessor)
+ if (scm_is_eq (class, scm_class_accessor))
{
SCM setter = scm_get_keyword (k_setter, args, SCM_BOOL_F);
if (scm_is_true (setter))
{
z = scm_sys_allocate_instance (class, args);
- if (class == scm_class_method
- || class == scm_class_accessor_method)
+ if (scm_is_eq (class, scm_class_method)
+ || scm_is_eq (class, scm_class_accessor_method))
{
SCM_SET_SLOT (z, scm_si_generic_function,
scm_i_get_keyword (k_gf,
scm_i_get_keyword (k_name,
args,
len - 1,
- scm_from_locale_symbol ("???"),
+ scm_from_latin1_symbol ("???"),
FUNC_NAME));
SCM_SET_SLOT (z, scm_si_direct_supers,
scm_i_get_keyword (k_dsupers,
*
******************************************************************************/
+/* Munge the CPL of C in place such that BEFORE appears before AFTER,
+ assuming that currently the reverse is true. Recalculate slots and
+ associated getters-n-setters. */
static void
fix_cpl (SCM c, SCM before, SCM after)
{
SCM cpl = SCM_SLOT (c, scm_si_cpl);
SCM ls = scm_c_memq (after, cpl);
- SCM tail = scm_delq1_x (before, SCM_CDR (ls));
+ SCM tail;
+
if (scm_is_false (ls))
/* if this condition occurs, fix_cpl should not be applied this way */
abort ();
+
+ tail = scm_delq1_x (before, SCM_CDR (ls));
SCM_SETCAR (ls, before);
SCM_SETCDR (ls, scm_cons (after, tail));
{
create_standard_classes (void)
{
SCM slots;
- SCM method_slots = scm_list_n (scm_from_locale_symbol ("generic-function"),
- scm_from_locale_symbol ("specializers"),
+ SCM method_slots = scm_list_n (scm_from_latin1_symbol ("generic-function"),
+ scm_from_latin1_symbol ("specializers"),
sym_procedure,
- scm_from_locale_symbol ("formals"),
- scm_from_locale_symbol ("body"),
- scm_from_locale_symbol ("make-procedure"),
+ scm_from_latin1_symbol ("formals"),
+ scm_from_latin1_symbol ("body"),
+ scm_from_latin1_symbol ("make-procedure"),
SCM_UNDEFINED);
- SCM amethod_slots = scm_list_1 (scm_list_3 (scm_from_locale_symbol ("slot-definition"),
+ SCM amethod_slots = scm_list_1 (scm_list_3 (scm_from_latin1_symbol ("slot-definition"),
k_init_keyword,
k_slot_definition));
- SCM gf_slots = scm_list_4 (scm_from_locale_symbol ("methods"),
- scm_list_3 (scm_from_locale_symbol ("n-specialized"),
+ SCM gf_slots = scm_list_4 (scm_from_latin1_symbol ("methods"),
+ scm_list_3 (scm_from_latin1_symbol ("n-specialized"),
k_init_value,
SCM_INUM0),
- scm_list_3 (scm_from_locale_symbol ("extended-by"),
+ scm_list_3 (scm_from_latin1_symbol ("extended-by"),
k_init_value,
SCM_EOL),
- scm_from_locale_symbol ("effective-methods"));
+ scm_from_latin1_symbol ("effective-methods"));
SCM setter_slots = scm_list_1 (sym_setter);
- SCM egf_slots = scm_list_1 (scm_list_3 (scm_from_locale_symbol ("extends"),
+ SCM egf_slots = scm_list_1 (scm_list_3 (scm_from_latin1_symbol ("extends"),
k_init_value,
SCM_EOL));
/* Foreign class slot classes */
make_stdcls (&scm_class_extended_generic_with_setter,
"<extended-generic-with-setter>",
scm_class_applicable_struct_class,
- scm_list_2 (scm_class_generic_with_setter,
- scm_class_extended_generic),
+ scm_list_2 (scm_class_extended_generic,
+ scm_class_generic_with_setter),
SCM_EOL);
SCM_SET_CLASS_FLAGS (scm_class_extended_generic_with_setter,
SCM_CLASSF_PURE_GENERIC);
scm_list_2 (scm_class_accessor,
scm_class_extended_generic_with_setter),
SCM_EOL);
+ /* <extended-generic> is misplaced. */
fix_cpl (scm_class_extended_accessor,
- scm_class_extended_generic, scm_class_generic);
+ scm_class_extended_generic, scm_class_generic_with_setter);
SCM_SET_CLASS_FLAGS (scm_class_extended_accessor, SCM_CLASSF_PURE_GENERIC);
/* Primitive types classes */
scm_class_class, scm_class_top, SCM_EOL);
make_stdcls (&scm_class_vector, "<vector>",
scm_class_class, scm_class_top, SCM_EOL);
+ make_stdcls (&class_foreign, "<foreign>",
+ scm_class_class, scm_class_top, SCM_EOL);
make_stdcls (&class_hashtable, "<hashtable>",
scm_class_class, scm_class_top, SCM_EOL);
make_stdcls (&class_fluid, "<fluid>",
scm_class_class, scm_class_top, SCM_EOL);
make_stdcls (&class_dynamic_state, "<dynamic-state>",
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>",
+ scm_class_class, scm_class_top, SCM_EOL);
+ make_stdcls (&class_uvec, "<uvec>",
+ scm_class_class, class_bytevector, SCM_EOL);
+ make_stdcls (&class_array, "<array>",
+ scm_class_class, scm_class_top, SCM_EOL);
+ make_stdcls (&class_bitvector, "<bitvector>",
+ scm_class_class, scm_class_top, SCM_EOL);
make_stdcls (&scm_class_number, "<number>",
scm_class_class, scm_class_top, SCM_EOL);
make_stdcls (&scm_class_complex, "<complex>",
make_class_from_symbol (SCM type_name_sym, SCM supers, int applicablep)
{
SCM class, name;
- if (type_name_sym != SCM_BOOL_F)
+ if (scm_is_true (type_name_sym))
{
name = scm_string_append (scm_list_3 (scm_from_locale_string ("<"),
scm_symbol_to_string (type_name_sym),
long i;
for (i = 0; i < SCM_I_MAX_SMOB_TYPE_COUNT; ++i)
- scm_smob_class[i] = 0;
+ 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_smob_class[i])
+ if (scm_is_false (scm_smob_class[i]))
scm_smob_class[i] = scm_make_extended_class (SCM_SMOBNAME (i),
scm_smobs[i].apply != 0);
}
make_struct_class (void *closure SCM_UNUSED,
SCM vtable, SCM data, SCM prev SCM_UNUSED)
{
- SCM sym = SCM_STRUCT_TABLE_NAME (data);
- if (scm_is_true (sym))
- {
- int applicablep = SCM_CLASS_FLAGS (vtable) & SCM_VTABLE_FLAG_APPLICABLE;
-
- SCM_SET_STRUCT_TABLE_CLASS (data,
- scm_make_extended_class_from_symbol (sym, applicablep));
- }
-
- scm_remember_upto_here_2 (data, vtable);
+ if (scm_is_false (data))
+ scm_i_define_class_for_vtable (vtable);
return SCM_UNSPECIFIED;
}
static void
create_struct_classes (void)
{
- scm_internal_hash_fold (make_struct_class, 0, SCM_BOOL_F, scm_struct_table);
+ /* FIXME: take the vtable_class_map while initializing goops? */
+ scm_internal_hash_fold (make_struct_class, 0, SCM_BOOL_F,
+ vtable_class_map);
}
/**********************************************************************
SCM
scm_ensure_accessor (SCM name)
{
- SCM gf = scm_call_2 (SCM_TOP_LEVEL_LOOKUP_CLOSURE, name, SCM_BOOL_F);
+ SCM var, gf;
+
+ var = scm_module_variable (scm_current_module (), name);
+ if (SCM_VARIABLEP (var) && !SCM_UNBNDP (SCM_VARIABLE_REF (var)))
+ gf = SCM_VARIABLE_REF (var);
+ else
+ gf = SCM_BOOL_F;
+
if (!SCM_IS_A_P (gf, scm_class_accessor))
{
gf = scm_make (scm_list_3 (scm_class_generic, k_name, name));
gf = scm_make (scm_list_5 (scm_class_accessor,
k_name, name, k_setter, gf));
}
- return gf;
-}
-SCM_SYMBOL (sym_internal_add_method_x, "internal-add-method!");
-
-void
-scm_add_method (SCM gf, SCM m)
-{
- scm_eval (scm_list_3 (sym_internal_add_method_x, gf, m), scm_module_goops);
+ return gf;
}
#ifdef GUILE_DEBUG
create_port_classes ();
{
- SCM name = scm_from_locale_symbol ("no-applicable-method");
+ SCM name = scm_from_latin1_symbol ("no-applicable-method");
scm_no_applicable_method =
scm_make (scm_list_3 (scm_class_generic, k_name, name));
DEFVAR (name, scm_no_applicable_method);
HCoop / bpt / guile.git / blobdiff