-/* Copyright (C) 1996,1997,1998,1999,2000,2001, 2003, 2004, 2006, 2007, 2008, 2009 Free Software Foundation, Inc.
+/* Copyright (C) 1996,1997,1998,1999,2000,2001, 2003, 2004, 2006, 2007, 2008, 2009, 2010, 2011, 2012 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
#endif
#include <alloca.h>
+#include <assert.h>
+
+#define SCM_BUILDING_DEPRECATED_CODE
#include "libguile/_scm.h"
#include "libguile/async.h"
#include "libguile/chars.h"
#include "libguile/eval.h"
#include "libguile/alist.h"
-#include "libguile/weaks.h"
#include "libguile/hashtab.h"
#include "libguile/ports.h"
#include "libguile/strings.h"
static SCM required_vtable_fields = SCM_BOOL_F;
static SCM required_applicable_fields = SCM_BOOL_F;
static SCM required_applicable_with_setter_fields = SCM_BOOL_F;
-SCM scm_struct_table = SCM_BOOL_F;
SCM scm_applicable_struct_vtable_vtable;
SCM scm_applicable_struct_with_setter_vtable_vtable;
SCM scm_standard_vtable_vtable;
#undef FUNC_NAME
\f
+/* Check whether VTABLE instances have a simple layout (i.e., either only "pr"
+ or only "pw" fields) and update its flags accordingly. */
+static void
+set_vtable_layout_flags (SCM vtable)
+{
+ size_t len, field;
+ SCM layout;
+ const char *c_layout;
+ scm_t_bits flags = SCM_VTABLE_FLAG_SIMPLE;
+
+ layout = SCM_VTABLE_LAYOUT (vtable);
+ c_layout = scm_i_symbol_chars (layout);
+ len = scm_i_symbol_length (layout);
+
+ assert (len % 2 == 0);
+
+ /* Update FLAGS according to LAYOUT. */
+ for (field = 0;
+ field < len && flags & SCM_VTABLE_FLAG_SIMPLE;
+ field += 2)
+ {
+ if (c_layout[field] != 'p')
+ flags = 0;
+ else
+ switch (c_layout[field + 1])
+ {
+ case 'w':
+ case 'W':
+ if (field == 0)
+ flags |= SCM_VTABLE_FLAG_SIMPLE_RW;
+ break;
+
+ case 'r':
+ case 'R':
+ flags &= ~SCM_VTABLE_FLAG_SIMPLE_RW;
+ break;
+
+ default:
+ flags = 0;
+ }
+ }
+
+ if (flags & SCM_VTABLE_FLAG_SIMPLE)
+ {
+ /* VTABLE is simple so update its flags and record the size of its
+ instances. */
+ SCM_SET_VTABLE_FLAGS (vtable, flags);
+ SCM_STRUCT_DATA_SET (vtable, scm_vtable_index_size, len / 2);
+ }
+}
+
+static int
+scm_is_valid_vtable_layout (SCM layout)
+{
+ size_t len, n;
+ const char *c_layout;
+
+ c_layout = scm_i_symbol_chars (layout);
+ len = scm_i_symbol_length (layout);
+
+ if (len % 2)
+ return 0;
+
+ for (n = 0; n < len; n += 2)
+ switch (c_layout[n])
+ {
+ case 'u':
+ case 'p':
+ case 's':
+ switch (c_layout[n+1])
+ {
+ case 'W':
+ case 'R':
+ case 'O':
+ if (n + 2 != len)
+ return 0;
+ case 'w':
+ case 'h':
+ case 'r':
+ case 'o':
+ break;
+ default:
+ return 0;
+ }
+ break;
+ default:
+ return 0;
+ }
+ return 1;
+}
+/* Have OBJ, a newly created vtable, inherit flags from VTABLE. VTABLE is a
+ vtable-vtable and OBJ is an instance of VTABLE. */
void
scm_i_struct_inherit_vtable_magic (SCM vtable, SCM obj)
#define FUNC_NAME "%inherit-vtable-magic"
Both of these questions also imply a certain layout of the structure. So
instead of checking the layout at runtime, what we do is pre-verify the
layout -- so that at runtime we can just check the applicable flag and
- dispatch directly to the Scheme procedure in slot 0.
- */
+ dispatch directly to the Scheme procedure in slot 0. */
SCM olayout;
- /* verify that obj is a valid vtable */
- if (scm_is_false (scm_symbol_p (SCM_VTABLE_LAYOUT (obj))))
- scm_misc_error (FUNC_NAME, "invalid layout for new vtable",
+ /* Verify that OBJ is a valid vtable. */
+ if (! scm_is_valid_vtable_layout (SCM_VTABLE_LAYOUT (obj)))
+ SCM_MISC_ERROR ("invalid layout for new vtable: ~a",
scm_list_1 (SCM_VTABLE_LAYOUT (obj)));
- /* if obj's vtable is compatible with the required vtable (class) layout, it
- is a metaclass */
+ set_vtable_layout_flags (obj);
+
+ /* If OBJ's vtable is compatible with the required vtable (class) layout, it
+ is a metaclass. */
olayout = scm_symbol_to_string (SCM_VTABLE_LAYOUT (obj));
if (scm_is_true (scm_leq_p (scm_string_length (required_vtable_fields),
scm_string_length (olayout)))
scm_string_length (required_vtable_fields))))
SCM_SET_VTABLE_FLAGS (obj, SCM_VTABLE_FLAG_VTABLE);
- /* finally if obj is an applicable class, verify that its vtable is
- compatible with the required applicable layout */
+ /* Finally, if OBJ is an applicable class, verify that its vtable is
+ compatible with the required applicable layout. */
if (SCM_VTABLE_FLAG_IS_SET (vtable, SCM_VTABLE_FLAG_SETTER_VTABLE))
{
if (scm_is_false (scm_string_eq (olayout, required_applicable_with_setter_fields,
scm_from_size_t (4),
scm_from_size_t (0),
scm_from_size_t (4))))
- scm_misc_error (FUNC_NAME, "invalid applicable-with-setter struct layout",
+ SCM_MISC_ERROR ("invalid applicable-with-setter struct layout",
scm_list_1 (olayout));
SCM_SET_VTABLE_FLAGS (obj, SCM_VTABLE_FLAG_APPLICABLE | SCM_VTABLE_FLAG_SETTER);
}
scm_from_size_t (2),
scm_from_size_t (0),
scm_from_size_t (2))))
- scm_misc_error (FUNC_NAME, "invalid applicable struct layout",
+ SCM_MISC_ERROR ("invalid applicable struct layout",
scm_list_1 (olayout));
SCM_SET_VTABLE_FLAGS (obj, SCM_VTABLE_FLAG_APPLICABLE);
}
+
+ SCM_SET_VTABLE_FLAGS (obj, SCM_VTABLE_FLAG_VALIDATED);
}
#undef FUNC_NAME
scm_struct_init (SCM handle, SCM layout, size_t n_tail,
size_t n_inits, scm_t_bits *inits)
{
- scm_t_wchar prot = 0;
- int n_fields = scm_i_symbol_length (layout) / 2;
- int tailp = 0;
- int i;
- size_t inits_idx = 0;
- scm_t_bits *mem = SCM_STRUCT_DATA (handle);
-
- i = -2;
- while (n_fields)
+ SCM vtable;
+ scm_t_bits *mem;
+
+ vtable = SCM_STRUCT_VTABLE (handle);
+ mem = SCM_STRUCT_DATA (handle);
+
+ if (SCM_UNPACK (vtable) != 0
+ && SCM_VTABLE_FLAG_IS_SET (vtable, SCM_VTABLE_FLAG_SIMPLE)
+ && n_tail == 0
+ && n_inits == SCM_STRUCT_DATA_REF (vtable, scm_vtable_index_size))
+ /* The fast path: HANDLE has N_INITS "p" fields. */
+ memcpy (mem, inits, n_inits * sizeof (SCM));
+ else
{
- if (!tailp)
+ scm_t_wchar prot = 0;
+ int n_fields = scm_i_symbol_length (layout) / 2;
+ int tailp = 0;
+ int i;
+ size_t inits_idx = 0;
+
+ i = -2;
+ while (n_fields)
{
- i += 2;
- prot = scm_i_symbol_ref (layout, i+1);
- if (SCM_LAYOUT_TAILP (prot))
+ if (!tailp)
{
- tailp = 1;
- prot = prot == 'R' ? 'r' : prot == 'W' ? 'w' : 'o';
- *mem++ = (scm_t_bits)n_tail;
- n_fields += n_tail - 1;
- if (n_fields == 0)
- break;
+ i += 2;
+ prot = scm_i_symbol_ref (layout, i+1);
+ if (SCM_LAYOUT_TAILP (prot))
+ {
+ tailp = 1;
+ prot = prot == 'R' ? 'r' : prot == 'W' ? 'w' : 'o';
+ *mem++ = (scm_t_bits)n_tail;
+ n_fields += n_tail - 1;
+ if (n_fields == 0)
+ break;
+ }
}
- }
- switch (scm_i_symbol_ref (layout, i))
- {
- case 'u':
- if ((prot != 'r' && prot != 'w') || inits_idx == n_inits)
- *mem = 0;
- else
+ switch (scm_i_symbol_ref (layout, i))
{
- *mem = scm_to_ulong (SCM_PACK (inits[inits_idx]));
- inits_idx++;
+ case 'u':
+ if ((prot != 'r' && prot != 'w') || inits_idx == n_inits)
+ *mem = 0;
+ else
+ {
+ *mem = scm_to_ulong (SCM_PACK (inits[inits_idx]));
+ inits_idx++;
+ }
+ break;
+
+ case 'p':
+ if ((prot != 'r' && prot != 'w') || inits_idx == n_inits)
+ *mem = SCM_UNPACK (SCM_BOOL_F);
+ else
+ {
+ *mem = inits[inits_idx];
+ inits_idx++;
+ }
+
+ break;
+
+ case 's':
+ *mem = SCM_UNPACK (handle);
+ break;
}
- break;
- case 'p':
- if ((prot != 'r' && prot != 'w') || inits_idx == n_inits)
- *mem = SCM_UNPACK (SCM_BOOL_F);
- else
- {
- *mem = inits[inits_idx];
- inits_idx++;
- }
-
- break;
-
- case 's':
- *mem = SCM_UNPACK (handle);
- break;
+ n_fields--;
+ mem++;
}
-
- n_fields--;
- mem++;
}
}
"Return @code{#t} iff @var{x} is a vtable structure.")
#define FUNC_NAME s_scm_struct_vtable_p
{
- return scm_from_bool
- (SCM_STRUCTP (x)
- && SCM_STRUCT_VTABLE_FLAG_IS_SET (x, SCM_VTABLE_FLAG_VTABLE));
+ if (!SCM_STRUCTP (x)
+ || !SCM_STRUCT_VTABLE_FLAG_IS_SET (x, SCM_VTABLE_FLAG_VTABLE))
+ return SCM_BOOL_F;
+ if (!SCM_VTABLE_FLAG_IS_SET (x, SCM_VTABLE_FLAG_VALIDATED))
+ SCM_MISC_ERROR ("vtable has invalid layout: ~A",
+ scm_list_1 (SCM_VTABLE_LAYOUT (x)));
+ return SCM_BOOL_T;
}
#undef FUNC_NAME
SCM
scm_i_alloc_struct (scm_t_bits *vtable_data, int n_words)
{
- scm_t_bits ret;
- ret = (scm_t_bits)scm_gc_malloc (sizeof (scm_t_bits) * (n_words + 2), "struct");
- SCM_SET_CELL_WORD_0 (SCM_PACK (ret), (scm_t_bits)vtable_data | scm_tc3_struct);
- SCM_SET_CELL_WORD_1 (SCM_PACK (ret),
- (scm_t_bits)SCM_CELL_OBJECT_LOC (SCM_PACK (ret), 2));
+ SCM ret;
+
+ ret = scm_words ((scm_t_bits)vtable_data | scm_tc3_struct, n_words + 2);
+ SCM_SET_CELL_WORD_1 (ret, (scm_t_bits)SCM_CELL_OBJECT_LOC (ret, 2));
/* vtable_data can be null when making a vtable vtable */
if (vtable_data && vtable_data[scm_vtable_index_instance_finalize])
- {
- /* Register a finalizer for the newly created instance. */
- GC_finalization_proc prev_finalizer;
- GC_PTR prev_finalizer_data;
- GC_REGISTER_FINALIZER_NO_ORDER ((void*)ret,
- struct_finalizer_trampoline,
- NULL,
- &prev_finalizer,
- &prev_finalizer_data);
- }
+ /* Register a finalizer for the newly created instance. */
+ scm_i_set_finalizer (SCM2PTR (ret), struct_finalizer_trampoline, NULL);
- return SCM_PACK (ret);
+ return ret;
}
\f
scm_struct_init (obj, layout, n_tail, n_init, init);
- /* only check things and inherit magic if the layout was passed as an initarg.
- something of a hack, but it's for back-compatibility. */
+ /* If we're making a vtable, validate its layout and inherit
+ flags. However we allow for separation of allocation and
+ initialization, to humor GOOPS, so only validate if the layout was
+ passed as an initarg. */
if (SCM_VTABLE_FLAG_IS_SET (vtable, SCM_VTABLE_FLAG_VTABLE)
&& scm_is_true (SCM_VTABLE_LAYOUT (obj)))
scm_i_struct_inherit_vtable_magic (vtable, obj);
SCM_DEFINE (scm_make_struct, "make-struct", 2, 0, 1,
(SCM vtable, SCM tail_array_size, SCM init),
"Create a new structure.\n\n"
- "@var{type} must be a vtable structure (@pxref{Vtables}).\n\n"
- "@var{tail-elts} must be a non-negative integer. If the layout\n"
- "specification indicated by @var{type} includes a tail-array,\n"
+ "@var{vtable} must be a vtable structure (@pxref{Vtables}).\n\n"
+ "@var{tail_array_size} must be a non-negative integer. If the layout\n"
+ "specification indicated by @var{vtable} includes a tail-array,\n"
"this is the number of elements allocated to that array.\n\n"
"The @var{init1}, @dots{} are optional arguments describing how\n"
"successive fields of the structure should be initialized. Only fields\n"
+#if SCM_ENABLE_DEPRECATED == 1
SCM_DEFINE (scm_make_vtable_vtable, "make-vtable-vtable", 2, 0, 1,
(SCM user_fields, SCM tail_array_size, SCM init),
"Return a new, self-describing vtable structure.\n\n"
"@var{user-fields} is a string describing user defined fields of the\n"
"vtable beginning at index @code{vtable-offset-user}\n"
"(see @code{make-struct-layout}).\n\n"
- "@var{tail-size} specifies the size of the tail-array (if any) of\n"
+ "@var{tail_array_size} specifies the size of the tail-array (if any) of\n"
"this vtable.\n\n"
"@var{init1}, @dots{} are the optional initializers for the fields of\n"
"the vtable.\n\n"
"@end lisp")
#define FUNC_NAME s_scm_make_vtable_vtable
{
- SCM fields;
- SCM layout;
- size_t basic_size;
- size_t n_tail, i, n_init;
- SCM obj;
+ SCM fields, layout, obj;
+ size_t basic_size, n_tail, i, n_init;
long ilen;
scm_t_bits *v;
fields = scm_string_append (scm_list_2 (required_vtable_fields,
user_fields));
layout = scm_make_struct_layout (fields);
+ if (!scm_is_valid_vtable_layout (layout))
+ SCM_MISC_ERROR ("invalid user fields", scm_list_1 (user_fields));
+
basic_size = scm_i_symbol_length (layout) / 2;
n_tail = scm_to_size_t (tail_array_size);
SCM_CRITICAL_SECTION_START;
obj = scm_i_alloc_struct (NULL, basic_size + n_tail);
- /* magic magic magic */
- SCM_SET_CELL_WORD_0 (obj, (scm_t_bits)SCM_STRUCT_DATA (obj) | scm_tc3_struct);
+ /* Make it so that the vtable of OBJ is itself. */
+ SCM_SET_CELL_WORD_0 (obj, (scm_t_bits) SCM_STRUCT_DATA (obj) | scm_tc3_struct);
SCM_CRITICAL_SECTION_END;
+
scm_struct_init (obj, layout, n_tail, n_init, v);
- SCM_SET_VTABLE_FLAGS (obj, SCM_VTABLE_FLAG_VTABLE);
+ SCM_SET_VTABLE_FLAGS (obj,
+ SCM_VTABLE_FLAG_VTABLE | SCM_VTABLE_FLAG_VALIDATED);
+
return obj;
}
#undef FUNC_NAME
+#endif
+
+SCM
+scm_i_make_vtable_vtable (SCM user_fields)
+#define FUNC_NAME s_scm_make_vtable_vtable
+{
+ SCM fields, layout, obj;
+ size_t basic_size;
+ scm_t_bits v;
+
+ SCM_VALIDATE_STRING (1, user_fields);
+ fields = scm_string_append (scm_list_2 (required_vtable_fields,
+ user_fields));
+ layout = scm_make_struct_layout (fields);
+ if (!scm_is_valid_vtable_layout (layout))
+ SCM_MISC_ERROR ("invalid user fields", scm_list_1 (user_fields));
+
+ basic_size = scm_i_symbol_length (layout) / 2;
+
+ obj = scm_i_alloc_struct (NULL, basic_size);
+ /* Make it so that the vtable of OBJ is itself. */
+ SCM_SET_CELL_WORD_0 (obj, (scm_t_bits) SCM_STRUCT_DATA (obj) | scm_tc3_struct);
+
+ v = SCM_UNPACK (layout);
+ scm_struct_init (obj, layout, 0, 1, &v);
+ SCM_SET_VTABLE_FLAGS (obj,
+ SCM_VTABLE_FLAG_VTABLE | SCM_VTABLE_FLAG_VALIDATED);
+
+ return obj;
+}
+#undef FUNC_NAME
SCM_DEFINE (scm_make_vtable, "make-vtable", 1, 1, 0,
(SCM fields, SCM printer),
SCM_DEFINE (scm_struct_ref, "struct-ref", 2, 0, 0,
(SCM handle, SCM pos),
- "Access the @var{n}th field of @var{struct}.\n\n"
- "If the field is of type 'p', then it can be set to an arbitrary value.\n\n"
- "If the field is of type 'u', then it can only be set to a non-negative\n"
- "integer value small enough to fit in one machine word.")
+ "Access the @var{pos}th field of struct associated with\n"
+ "@var{handle}.\n"
+ "\n"
+ "If the field is of type 'p', then it can be set to an arbitrary\n"
+ "value.\n"
+ "\n"
+ "If the field is of type 'u', then it can only be set to a\n"
+ "non-negative integer value small enough to fit in one machine\n"
+ "word.")
#define FUNC_NAME s_scm_struct_ref
{
- SCM answer = SCM_UNDEFINED;
- scm_t_bits * data;
- SCM layout;
- size_t layout_len;
+ SCM vtable, answer = SCM_UNDEFINED;
+ scm_t_bits *data;
size_t p;
- scm_t_bits n_fields;
- scm_t_wchar field_type = 0;
-
SCM_VALIDATE_STRUCT (1, handle);
- layout = SCM_STRUCT_LAYOUT (handle);
+ vtable = SCM_STRUCT_VTABLE (handle);
data = SCM_STRUCT_DATA (handle);
p = scm_to_size_t (pos);
- layout_len = scm_i_symbol_length (layout);
- n_fields = layout_len / 2;
- if (SCM_LAYOUT_TAILP (scm_i_symbol_ref (layout, layout_len - 1)))
- n_fields += data[n_fields - 1];
-
- SCM_ASSERT_RANGE(1, pos, p < n_fields);
-
- if (p * 2 < layout_len)
+ if (SCM_LIKELY (SCM_VTABLE_FLAG_IS_SET (vtable, SCM_VTABLE_FLAG_SIMPLE)
+ && p < SCM_STRUCT_DATA_REF (vtable, scm_vtable_index_size)))
+ /* The fast path: HANDLE is a struct with only "p" fields. */
+ answer = SCM_PACK (data[p]);
+ else
{
- scm_t_wchar ref;
- field_type = scm_i_symbol_ref (layout, p * 2);
- ref = scm_i_symbol_ref (layout, p * 2 + 1);
- if ((ref != 'r') && (ref != 'w') && (ref != 'h'))
+ SCM layout;
+ size_t layout_len, n_fields;
+ scm_t_wchar field_type = 0;
+
+ layout = SCM_STRUCT_LAYOUT (handle);
+ layout_len = scm_i_symbol_length (layout);
+ n_fields = layout_len / 2;
+
+ if (SCM_LAYOUT_TAILP (scm_i_symbol_ref (layout, layout_len - 1)))
+ n_fields += data[n_fields - 1];
+
+ SCM_ASSERT_RANGE (1, pos, p < n_fields);
+
+ if (p * 2 < layout_len)
{
- if ((ref == 'R') || (ref == 'W'))
- field_type = 'u';
- else
- SCM_MISC_ERROR ("ref denied for field ~A", scm_list_1 (pos));
+ scm_t_wchar ref;
+ field_type = scm_i_symbol_ref (layout, p * 2);
+ ref = scm_i_symbol_ref (layout, p * 2 + 1);
+ if ((ref != 'r') && (ref != 'w') && (ref != 'h'))
+ {
+ if ((ref == 'R') || (ref == 'W'))
+ field_type = 'u';
+ else
+ SCM_MISC_ERROR ("ref denied for field ~A", scm_list_1 (pos));
+ }
}
- }
- else if (scm_i_symbol_ref (layout, layout_len - 1) != 'O')
- field_type = scm_i_symbol_ref(layout, layout_len - 2);
- else
- SCM_MISC_ERROR ("ref denied for field ~A", scm_list_1 (pos));
-
- switch (field_type)
- {
- case 'u':
- answer = scm_from_ulong (data[p]);
- break;
+ else if (scm_i_symbol_ref (layout, layout_len - 1) != 'O')
+ field_type = scm_i_symbol_ref(layout, layout_len - 2);
+ else
+ SCM_MISC_ERROR ("ref denied for field ~A", scm_list_1 (pos));
+
+ switch (field_type)
+ {
+ case 'u':
+ answer = scm_from_ulong (data[p]);
+ break;
#if 0
- case 'i':
- answer = scm_from_long (data[p]);
- break;
+ case 'i':
+ answer = scm_from_long (data[p]);
+ break;
- case 'd':
- answer = scm_make_real (*((double *)&(data[p])));
- break;
+ case 'd':
+ answer = scm_make_real (*((double *)&(data[p])));
+ break;
#endif
- case 's':
- case 'p':
- answer = SCM_PACK (data[p]);
- break;
+ case 's':
+ case 'p':
+ answer = SCM_PACK (data[p]);
+ break;
- default:
- SCM_MISC_ERROR ("unrecognized field type: ~S",
- scm_list_1 (SCM_MAKE_CHAR (field_type)));
+ default:
+ SCM_MISC_ERROR ("unrecognized field type: ~S",
+ scm_list_1 (SCM_MAKE_CHAR (field_type)));
+ }
}
return answer;
"to.")
#define FUNC_NAME s_scm_struct_set_x
{
- scm_t_bits * data;
- SCM layout;
- size_t layout_len;
+ SCM vtable;
+ scm_t_bits *data;
size_t p;
- int n_fields;
- scm_t_wchar field_type = 0;
SCM_VALIDATE_STRUCT (1, handle);
- layout = SCM_STRUCT_LAYOUT (handle);
+ vtable = SCM_STRUCT_VTABLE (handle);
data = SCM_STRUCT_DATA (handle);
p = scm_to_size_t (pos);
- layout_len = scm_i_symbol_length (layout);
- n_fields = layout_len / 2;
- if (SCM_LAYOUT_TAILP (scm_i_symbol_ref (layout, layout_len - 1)))
- n_fields += data[n_fields - 1];
+ if (SCM_LIKELY (SCM_VTABLE_FLAG_IS_SET (vtable, SCM_VTABLE_FLAG_SIMPLE)
+ && SCM_VTABLE_FLAG_IS_SET (vtable, SCM_VTABLE_FLAG_SIMPLE_RW)
+ && p < SCM_STRUCT_DATA_REF (vtable, scm_vtable_index_size)))
+ /* The fast path: HANDLE is a struct with only "pw" fields. */
+ data[p] = SCM_UNPACK (val);
+ else
+ {
+ SCM layout;
+ size_t layout_len, n_fields;
+ scm_t_wchar field_type = 0;
- SCM_ASSERT_RANGE (1, pos, p < n_fields);
+ layout = SCM_STRUCT_LAYOUT (handle);
+ layout_len = scm_i_symbol_length (layout);
+ n_fields = layout_len / 2;
- if (p * 2 < layout_len)
- {
- char set_x;
- field_type = scm_i_symbol_ref (layout, p * 2);
- set_x = scm_i_symbol_ref (layout, p * 2 + 1);
- if (set_x != 'w' && set_x != 'h')
+ if (SCM_LAYOUT_TAILP (scm_i_symbol_ref (layout, layout_len - 1)))
+ n_fields += data[n_fields - 1];
+
+ SCM_ASSERT_RANGE (1, pos, p < n_fields);
+
+ if (p * 2 < layout_len)
+ {
+ char set_x;
+ field_type = scm_i_symbol_ref (layout, p * 2);
+ set_x = scm_i_symbol_ref (layout, p * 2 + 1);
+ if (set_x != 'w' && set_x != 'h')
+ SCM_MISC_ERROR ("set! denied for field ~A", scm_list_1 (pos));
+ }
+ else if (scm_i_symbol_ref (layout, layout_len - 1) == 'W')
+ field_type = scm_i_symbol_ref (layout, layout_len - 2);
+ else
SCM_MISC_ERROR ("set! denied for field ~A", scm_list_1 (pos));
- }
- else if (scm_i_symbol_ref (layout, layout_len - 1) == 'W')
- field_type = scm_i_symbol_ref (layout, layout_len - 2);
- else
- SCM_MISC_ERROR ("set! denied for field ~A", scm_list_1 (pos));
-
- switch (field_type)
- {
- case 'u':
- data[p] = SCM_NUM2ULONG (3, val);
- break;
+
+ switch (field_type)
+ {
+ case 'u':
+ data[p] = SCM_NUM2ULONG (3, val);
+ break;
#if 0
- case 'i':
- data[p] = SCM_NUM2LONG (3, val);
- break;
+ case 'i':
+ data[p] = SCM_NUM2LONG (3, val);
+ break;
- case 'd':
- *((double *)&(data[p])) = scm_num2dbl (val, (char *)SCM_ARG3);
- break;
+ case 'd':
+ *((double *)&(data[p])) = scm_num2dbl (val, (char *)SCM_ARG3);
+ break;
#endif
- case 'p':
- data[p] = SCM_UNPACK (val);
- break;
+ case 'p':
+ data[p] = SCM_UNPACK (val);
+ break;
- case 's':
- SCM_MISC_ERROR ("self fields immutable", SCM_EOL);
+ case 's':
+ SCM_MISC_ERROR ("self fields immutable", SCM_EOL);
- default:
- SCM_MISC_ERROR ("unrecognized field type: ~S",
- scm_list_1 (SCM_MAKE_CHAR (field_type)));
+ default:
+ SCM_MISC_ERROR ("unrecognized field type: ~S",
+ scm_list_1 (SCM_MAKE_CHAR (field_type)));
+ }
}
return val;
SCM_DEFINE (scm_struct_vtable, "struct-vtable", 1, 0, 0,
(SCM handle),
- "Return the vtable structure that describes the type of @var{struct}.")
+ "Return the vtable structure that describes the type of struct\n"
+ "associated with @var{handle}.")
#define FUNC_NAME s_scm_struct_vtable
{
SCM_VALIDATE_STRUCT (1, handle);
#define FUNC_NAME s_scm_struct_vtable_tag
{
SCM_VALIDATE_VTABLE (1, handle);
- return scm_from_ulong (((unsigned long)SCM_STRUCT_DATA (handle)) >> 3);
+ return scm_from_unsigned_integer
+ (((scm_t_bits)SCM_STRUCT_DATA (handle)) >> 3);
}
#undef FUNC_NAME
return SCM_UNPACK (obj) % n;
}
-SCM
-scm_struct_create_handle (SCM obj)
-{
- SCM handle = scm_hash_fn_create_handle_x (scm_struct_table,
- obj,
- SCM_BOOL_F,
- scm_struct_ihashq,
- (scm_t_assoc_fn) scm_sloppy_assq,
- 0);
- if (scm_is_false (SCM_CDR (handle)))
- SCM_SETCDR (handle, scm_cons (SCM_BOOL_F, SCM_BOOL_F));
- return handle;
-}
-
SCM_DEFINE (scm_struct_vtable_name, "struct-vtable-name", 1, 0, 0,
(SCM vtable),
"Return the name of the vtable @var{vtable}.")
#define FUNC_NAME s_scm_struct_vtable_name
{
SCM_VALIDATE_VTABLE (1, vtable);
- return SCM_STRUCT_TABLE_NAME (SCM_CDR (scm_struct_create_handle (vtable)));
+ return SCM_VTABLE_NAME (vtable);
}
#undef FUNC_NAME
{
SCM_VALIDATE_VTABLE (1, vtable);
SCM_VALIDATE_SYMBOL (2, name);
- SCM_SET_STRUCT_TABLE_NAME (SCM_CDR (scm_struct_create_handle (vtable)),
- name);
+ SCM_SET_VTABLE_NAME (vtable, name);
+ /* FIXME: remove this, and implement proper struct classes instead.
+ (Vtables *are* classes.) */
+ scm_i_define_class_for_vtable (vtable);
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
{
SCM vtable = SCM_STRUCT_VTABLE (exp);
SCM name = scm_struct_vtable_name (vtable);
- scm_puts ("#<", port);
+ scm_puts_unlocked ("#<", port);
if (scm_is_true (name))
{
scm_display (name, port);
- scm_putc (' ', port);
+ scm_putc_unlocked (' ', port);
}
else
{
if (SCM_VTABLE_FLAG_IS_SET (vtable, SCM_VTABLE_FLAG_VTABLE))
- scm_puts ("vtable:", port);
+ scm_puts_unlocked ("vtable:", port);
else
- scm_puts ("struct:", port);
+ scm_puts_unlocked ("struct:", port);
scm_uintprint (SCM_UNPACK (vtable), 16, port);
- scm_putc (' ', port);
+ scm_putc_unlocked (' ', port);
scm_write (SCM_VTABLE_LAYOUT (vtable), port);
- scm_putc (' ', port);
+ scm_putc_unlocked (' ', port);
}
scm_uintprint (SCM_UNPACK (exp), 16, port);
/* hackety hack */
{
if (scm_is_true (SCM_STRUCT_PROCEDURE (exp)))
{
- scm_puts (" proc: ", port);
+ scm_puts_unlocked (" proc: ", port);
if (scm_is_true (scm_procedure_p (SCM_STRUCT_PROCEDURE (exp))))
scm_write (SCM_STRUCT_PROCEDURE (exp), port);
else
- scm_puts ("(not a procedure?)", port);
+ scm_puts_unlocked ("(not a procedure?)", port);
}
if (SCM_STRUCT_SETTER_P (exp))
{
- scm_puts (" setter: ", port);
+ scm_puts_unlocked (" setter: ", port);
scm_write (SCM_STRUCT_SETTER (exp), port);
}
}
- scm_putc ('>', port);
+ scm_putc_unlocked ('>', port);
}
}
void
scm_init_struct ()
{
- GC_REGISTER_DISPLACEMENT (2*sizeof(scm_t_bits)); /* for the self data pointer */
- GC_REGISTER_DISPLACEMENT (2*sizeof(scm_t_bits)
- + scm_tc3_struct); /* for the vtable data pointer */
+ /* The first word of a struct is equal to `SCM_STRUCT_DATA (vtable) +
+ scm_tc3_struct', and `SCM_STRUCT_DATA (vtable)' is 2 words after VTABLE by
+ default. */
+ GC_REGISTER_DISPLACEMENT (2 * sizeof (scm_t_bits) + scm_tc3_struct);
+
+ /* In the general case, `SCM_STRUCT_DATA (obj)' points 2 words after the
+ beginning of a GC-allocated region; that region is different from that of
+ OBJ once OBJ has undergone class redefinition. */
+ GC_REGISTER_DISPLACEMENT (2 * sizeof (scm_t_bits));
- scm_struct_table = scm_make_weak_key_hash_table (scm_from_int (31));
required_vtable_fields = scm_from_locale_string (SCM_VTABLE_BASE_LAYOUT);
+ scm_c_define ("standard-vtable-fields", required_vtable_fields);
required_applicable_fields = scm_from_locale_string (SCM_APPLICABLE_BASE_LAYOUT);
required_applicable_with_setter_fields = scm_from_locale_string (SCM_APPLICABLE_WITH_SETTER_BASE_LAYOUT);
- scm_standard_vtable_vtable =
- scm_make_vtable_vtable (scm_nullstr, SCM_INUM0, SCM_EOL);
+ scm_standard_vtable_vtable = scm_i_make_vtable_vtable (scm_nullstr);
+ scm_c_define ("<standard-vtable>", scm_standard_vtable_vtable);
scm_applicable_struct_vtable_vtable =
scm_make_struct (scm_standard_vtable_vtable, SCM_INUM0,
HCoop / bpt / guile.git / blobdiff