-/* Copyright (C) 1996,1997,1998,1999,2000,2001, 2003, 2004, 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013 Free Software Foundation, Inc.
+/* Copyright (C) 1996,1997,1998,1999,2000,2001, 2003, 2004, 2006, 2007,
+ * 2008, 2009, 2010, 2011, 2012, 2013, 2015 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
#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"
return scm_c_make_structv (vtable, n_tail, n_init, v);
}
+SCM_DEFINE (scm_allocate_struct, "allocate-struct", 2, 0, 0,
+ (SCM vtable, SCM nfields),
+ "Allocate a new structure with space for @var{nfields} fields.\n\n"
+ "@var{vtable} must be a vtable structure (@pxref{Vtables}).\n\n"
+ "@var{nfields} must be a non-negative integer. Strictly speaking\n"
+ "@var{nfields} is redundant, as the vtable carries the size\n"
+ "for its instances. However passing it is useful as a sanity\n"
+ "check, given that one module can inline a constructor in\n"
+ "another.\n\n"
+ "Fields will be initialized with their default values.")
+#define FUNC_NAME s_scm_allocate_struct
+{
+ SCM ret;
+ size_t c_nfields;
+
+ SCM_VALIDATE_VTABLE (1, vtable);
+ c_nfields = scm_to_size_t (nfields);
+
+ SCM_ASSERT (SCM_STRUCT_DATA_REF (vtable, scm_vtable_index_size) == c_nfields,
+ nfields, 2, FUNC_NAME);
+
+ ret = scm_i_alloc_struct (SCM_STRUCT_DATA (vtable), c_nfields);
+
+ if (SCM_LIKELY (SCM_VTABLE_FLAG_IS_SET (vtable, SCM_VTABLE_FLAG_SIMPLE)))
+ {
+ size_t n;
+ for (n = 0; n < c_nfields; n++)
+ SCM_STRUCT_DATA_SET (ret, n, SCM_UNPACK (SCM_BOOL_F));
+ }
+ else
+ scm_struct_init (ret, SCM_VTABLE_LAYOUT (vtable), 0, 0, NULL);
+
+ return ret;
+}
+#undef FUNC_NAME
+
SCM_DEFINE (scm_make_struct, "make-struct", 2, 0, 1,
(SCM vtable, SCM tail_array_size, SCM init),
"Create a new structure.\n\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}.")
+ "initialized to 0.")
#define FUNC_NAME s_scm_make_struct
{
size_t i, n_init;
}
#undef FUNC_NAME
-
-
-#if SCM_ENABLE_DEPRECATED == 1
SCM
-scm_make_vtable_vtable (SCM user_fields, SCM tail_array_size, SCM init)
+scm_i_make_vtable_vtable (SCM fields)
#define FUNC_NAME "make-vtable-vtable"
{
- SCM fields, layout, obj;
- size_t basic_size, n_tail, i, n_init;
- long ilen;
- scm_t_bits *v;
-
- SCM_VALIDATE_STRING (1, user_fields);
- 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);
- 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);
-
- 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 + n_tail);
- /* 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_VTABLE_FLAG_VALIDATED);
-
- return obj;
-}
-#undef FUNC_NAME
-#endif
-
-SCM
-scm_i_make_vtable_vtable (SCM user_fields)
-#define FUNC_NAME "make-vtable-vtable"
-{
- SCM fields, layout, obj;
+ SCM layout, obj;
size_t basic_size;
scm_t_bits v;
- SCM_VALIDATE_STRING (1, user_fields);
+ SCM_VALIDATE_STRING (1, 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));
+ SCM_MISC_ERROR ("invalid user fields", scm_list_1 (fields));
basic_size = scm_i_symbol_length (layout) / 2;
return SCM_UNPACK (obj) % n;
}
-/* Return the hash of struct OBJ, modulo N. Traverse OBJ's fields to
- compute the result, unless DEPTH is zero. */
-unsigned long
-scm_i_struct_hash (SCM obj, unsigned long n, size_t depth)
-#define FUNC_NAME "hash"
-{
- SCM layout;
- scm_t_bits *data;
- size_t struct_size, field_num;
- unsigned long hash;
-
- SCM_VALIDATE_STRUCT (1, obj);
-
- layout = SCM_STRUCT_LAYOUT (obj);
- struct_size = scm_i_symbol_length (layout) / 2;
- data = SCM_STRUCT_DATA (obj);
-
- hash = SCM_UNPACK (SCM_STRUCT_VTABLE (obj)) % n;
- if (depth > 0)
- for (field_num = 0; field_num < struct_size; field_num++)
- {
- int protection;
-
- protection = scm_i_symbol_ref (layout, field_num * 2 + 1);
- if (protection != 'h' && protection != 'o')
- {
- int type;
- type = scm_i_symbol_ref (layout, field_num * 2);
- switch (type)
- {
- case 'p':
- hash ^= scm_hasher (SCM_PACK (data[field_num]), n,
- depth / 2);
- break;
- case 'u':
- hash ^= data[field_num] % n;
- break;
- default:
- /* Ignore 's' fields. */;
- }
- }
- }
-
- /* FIXME: Tail elements should be taken into account. */
-
- return hash % n;
-}
-#undef FUNC_NAME
-
SCM_DEFINE (scm_struct_vtable_name, "struct-vtable-name", 1, 0, 0,
(SCM vtable),
"Return the name of the vtable @var{vtable}.")
{
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);
}
}
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_i_make_vtable_vtable (scm_nullstr);
+ scm_standard_vtable_vtable =
+ scm_i_make_vtable_vtable (required_vtable_fields);
name = scm_from_utf8_symbol ("<standard-vtable>");
scm_set_struct_vtable_name_x (scm_standard_vtable_vtable, name);
scm_define (name, scm_standard_vtable_vtable);
scm_from_int (scm_vtable_index_instance_printer));
scm_c_define ("vtable-offset-user", scm_from_int (scm_vtable_offset_user));
#include "libguile/struct.x"
-#if SCM_ENABLE_DEPRECATED
- scm_c_define_gsubr ("make-vtable-vtable", 2, 0, 1, scm_make_vtable_vtable);
-#endif
}
/*
HCoop / bpt / guile.git / blobdiff