summaryrefslogtreecommitdiff
path: root/libguile/struct.c
diff options
context:
space:
mode:
authorAndy Wingo <wingo@pobox.com>2009-12-07 11:14:01 +0100
committerAndy Wingo <wingo@pobox.com>2009-12-07 11:21:59 +0100
commit66e78727d602b0c59bf4633951eac17d3697bfc0 (patch)
tree8121466595e4d5dc1d5d0b7c929e548e3d905de0 /libguile/struct.c
parentea68d342f18c3d2082ce6a4fb39bd38b6af932cc (diff)
downloadguile-66e78727d602b0c59bf4633951eac17d3697bfc0.tar.gz
add scm_c_make_struct[v]
* libguile/struct.h (scm_c_make_struct, scm_c_make_structv): New functions with which you can make a struct without consing a rest list. * libguile/struct.c (scm_struct_init): Refactor to take an array of init values, not a list. (scm_make_struct, scm_make_vtable_vtable): Pull the rest arg out into a list and pass it down to the new array-taking functions. * libguile/memoize.c: Remove a neeless #include <alloca>.
Diffstat (limited to 'libguile/struct.c')
-rw-r--r--libguile/struct.c172
1 files changed, 107 insertions, 65 deletions
diff --git a/libguile/struct.c b/libguile/struct.c
index cd2c441e3..350ddce45 100644
--- a/libguile/struct.c
+++ b/libguile/struct.c
@@ -21,6 +21,8 @@
# include <config.h>
#endif
+#include <alloca.h>
+
#include "libguile/_scm.h"
#include "libguile/async.h"
#include "libguile/chars.h"
@@ -206,12 +208,14 @@ scm_i_struct_inherit_vtable_magic (SCM vtable, SCM obj)
static void
-scm_struct_init (SCM handle, SCM layout, int tail_elts, SCM inits)
+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;
@@ -225,60 +229,35 @@ scm_struct_init (SCM handle, SCM layout, int tail_elts, SCM inits)
{
tailp = 1;
prot = prot == 'R' ? 'r' : prot == 'W' ? 'w' : 'o';
- *mem++ = tail_elts;
- n_fields += tail_elts - 1;
+ *mem++ = (scm_t_bits)n_tail;
+ n_fields += n_tail - 1;
if (n_fields == 0)
break;
}
}
switch (scm_i_symbol_ref (layout, i))
{
-#if 0
- case 'i':
- if ((prot != 'r' && prot != 'w') || inits == SCM_EOL)
- *mem = 0;
- else
- {
- *mem = scm_to_long (SCM_CAR (inits));
- inits = SCM_CDR (inits);
- }
- break;
-#endif
-
case 'u':
- if ((prot != 'r' && prot != 'w') || scm_is_null (inits))
+ if ((prot != 'r' && prot != 'w') || inits_idx == n_inits)
*mem = 0;
else
{
- *mem = scm_to_ulong (SCM_CAR (inits));
- inits = SCM_CDR (inits);
+ *mem = scm_to_ulong (SCM_PACK (inits[inits_idx]));
+ inits_idx++;
}
break;
case 'p':
- if ((prot != 'r' && prot != 'w') || scm_is_null (inits))
+ if ((prot != 'r' && prot != 'w') || inits_idx == n_inits)
*mem = SCM_UNPACK (SCM_BOOL_F);
else
{
- *mem = SCM_UNPACK (SCM_CAR (inits));
- inits = SCM_CDR (inits);
+ *mem = inits[inits_idx];
+ inits_idx++;
}
break;
-#if 0
- case 'd':
- if ((prot != 'r' && prot != 'w') || inits == SCM_EOL)
- *((double *)mem) = 0.0;
- else
- {
- *mem = scm_num2dbl (SCM_CAR (inits), "scm_struct_init");
- inits = SCM_CDR (inits);
- }
- fields_desc += 2;
- break;
-#endif
-
case 's':
*mem = SCM_UNPACK (handle);
break;
@@ -363,40 +342,20 @@ scm_i_alloc_struct (scm_t_bits *vtable_data, int n_words, const char *what)
}
-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"
- "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"
- "with protection 'r' or 'w' can be initialized, except for fields of\n"
- "type 's', which are automatically initialized to point to the new\n"
- "structure itself. Fields with protection 'o' can not be initialized by\n"
- "Scheme programs.\n\n"
- "If fewer optional arguments than initializable fields are supplied,\n"
- "fields of type 'p' get default value #f while fields of type 'u' are\n"
- "initialized to 0.\n\n"
- "For more information, see the documentation for @code{make-vtable-vtable}.")
-#define FUNC_NAME s_scm_make_struct
+SCM
+scm_c_make_structv (SCM vtable, size_t n_tail, size_t n_init, scm_t_bits *init)
+#define FUNC_NAME "make-struct"
{
SCM layout;
size_t basic_size;
- size_t tail_elts;
SCM obj;
SCM_VALIDATE_VTABLE (1, vtable);
- SCM_VALIDATE_REST_ARGUMENT (init);
layout = SCM_VTABLE_LAYOUT (vtable);
basic_size = scm_i_symbol_length (layout) / 2;
- tail_elts = scm_to_size_t (tail_array_size);
- /* A tail array is only allowed if the layout fields string ends in "R",
- "W" or "O". */
- if (tail_elts != 0)
+ if (n_tail != 0)
{
SCM layout_str, last_char;
@@ -413,10 +372,10 @@ SCM_DEFINE (scm_make_struct, "make-struct", 2, 0, 1,
goto bad_tail;
}
- obj = scm_i_alloc_struct (SCM_STRUCT_DATA (vtable), basic_size + tail_elts,
+ obj = scm_i_alloc_struct (SCM_STRUCT_DATA (vtable), basic_size + n_tail,
"struct");
- scm_struct_init (obj, layout, tail_elts, init);
+ 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. */
@@ -428,6 +387,70 @@ SCM_DEFINE (scm_make_struct, "make-struct", 2, 0, 1,
}
#undef FUNC_NAME
+SCM
+scm_c_make_struct (SCM vtable, size_t n_tail, size_t n_init, scm_t_bits init, ...)
+{
+ va_list foo;
+ scm_t_bits *v;
+ size_t i;
+
+ v = alloca (sizeof (scm_t_bits) * n_init);
+
+ va_start (foo, init);
+ for (i = 0; i < n_init; i++)
+ {
+ v[i] = init;
+ init = va_arg (foo, scm_t_bits);
+ }
+ va_end (foo);
+
+ return scm_c_make_structv (vtable, n_tail, n_init, v);
+}
+
+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"
+ "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"
+ "with protection 'r' or 'w' can be initialized, except for fields of\n"
+ "type 's', which are automatically initialized to point to the new\n"
+ "structure itself. Fields with protection 'o' can not be initialized by\n"
+ "Scheme programs.\n\n"
+ "If fewer optional arguments than initializable fields are supplied,\n"
+ "fields of type 'p' get default value #f while fields of type 'u' are\n"
+ "initialized to 0.\n\n"
+ "For more information, see the documentation for @code{make-vtable-vtable}.")
+#define FUNC_NAME s_scm_make_struct
+{
+ size_t i, n_init;
+ long ilen;
+ scm_t_bits *v;
+
+ SCM_VALIDATE_VTABLE (1, vtable);
+ ilen = scm_ilength (init);
+ if (ilen < 0)
+ SCM_MISC_ERROR ("Rest arguments do not form a proper list.", SCM_EOL);
+
+ n_init = (size_t)ilen;
+
+ /* best to use alloca, but init could be big, so hack to avoid a possible
+ stack overflow */
+ if (n_init < 64)
+ v = alloca (n_init * sizeof(scm_t_bits));
+ else
+ v = scm_gc_malloc (n_init * sizeof(scm_t_bits), "struct");
+
+ for (i = 0; i < n_init; i++, init = SCM_CDR (init))
+ v[i] = SCM_UNPACK (SCM_CAR (init));
+
+ return scm_c_make_structv (vtable, scm_to_size_t (tail_array_size), n_init, v);
+}
+#undef FUNC_NAME
+
SCM_DEFINE (scm_make_vtable_vtable, "make-vtable-vtable", 2, 0, 1,
@@ -481,23 +504,42 @@ SCM_DEFINE (scm_make_vtable_vtable, "make-vtable-vtable", 2, 0, 1,
SCM fields;
SCM layout;
size_t basic_size;
- size_t tail_elts;
+ size_t n_tail, i, n_init;
SCM obj;
+ long ilen;
+ scm_t_bits *v;
SCM_VALIDATE_STRING (1, user_fields);
- SCM_VALIDATE_REST_ARGUMENT (init);
+ ilen = scm_ilength (init);
+ if (ilen < 0)
+ SCM_MISC_ERROR ("Rest arguments do not form a proper list.", SCM_EOL);
+
+ n_init = (size_t)ilen + 1; /* + 1 for the layout */
+
+ /* best to use alloca, but init could be big, so hack to avoid a possible
+ stack overflow */
+ if (n_init < 64)
+ v = alloca (n_init * sizeof(scm_t_bits));
+ else
+ v = scm_gc_malloc (n_init * sizeof(scm_t_bits), "struct");
fields = scm_string_append (scm_list_2 (required_vtable_fields,
user_fields));
layout = scm_make_struct_layout (fields);
basic_size = scm_i_symbol_length (layout) / 2;
- tail_elts = scm_to_size_t (tail_array_size);
+ n_tail = scm_to_size_t (tail_array_size);
+
+ i = 0;
+ v[i++] = SCM_UNPACK (layout);
+ for (; i < n_init; i++, init = SCM_CDR (init))
+ v[i] = SCM_UNPACK (SCM_CAR (init));
+
SCM_CRITICAL_SECTION_START;
- obj = scm_i_alloc_struct (NULL, basic_size + tail_elts, "struct");
+ obj = scm_i_alloc_struct (NULL, basic_size + n_tail, "struct");
/* magic magic magic */
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, tail_elts, scm_cons (layout, init));
+ scm_struct_init (obj, layout, n_tail, n_init, v);
SCM_SET_VTABLE_FLAGS (obj, SCM_VTABLE_FLAG_VTABLE);
return obj;
}