-/* Copyright (C) 1996,1997,1998,1999,2000,2001, 2003, 2004, 2006, 2007, 2008, 2009, 2010, 2011, 2012 Free Software Foundation, Inc.
+/* Copyright (C) 1996,1997,1998,1999,2000,2001, 2003, 2004, 2006, 2007,
+ * 2008, 2009, 2010, 2011, 2012, 2013 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
#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. */
+/* Check whether VTABLE instances have a simple layout (i.e., either
+ only "pr" or only "pw" fields and no tail array) and update its flags
+ accordingly. */
static void
set_vtable_layout_flags (SCM vtable)
{
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;
/* Finalization: invoke the finalizer of the struct pointed to by PTR. */
static void
-struct_finalizer_trampoline (GC_PTR ptr, GC_PTR unused_data)
+struct_finalizer_trampoline (void *ptr, void *unused_data)
{
SCM obj = PTR2SCM (ptr);
scm_t_struct_finalize finalize = SCM_STRUCT_FINALIZER (obj);
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_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_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"
- "Vtables have one initializable system field---the struct printer.\n"
- "This field comes before the user fields in the initializers passed\n"
- "to @code{make-vtable-vtable} and @code{make-struct}, and thus works as\n"
- "a third optional argument to @code{make-vtable-vtable} and a fourth to\n"
- "@code{make-struct} when creating vtables:\n\n"
- "If the value is a procedure, it will be called instead of the standard\n"
- "printer whenever a struct described by this vtable is printed.\n"
- "The procedure will be called with arguments STRUCT and PORT.\n\n"
- "The structure of a struct is described by a vtable, so the vtable is\n"
- "in essence the type of the struct. The vtable is itself a struct with\n"
- "a vtable. This could go on forever if it weren't for the\n"
- "vtable-vtables which are self-describing vtables, and thus terminate\n"
- "the chain.\n\n"
- "There are several potential ways of using structs, but the standard\n"
- "one is to use three kinds of structs, together building up a type\n"
- "sub-system: one vtable-vtable working as the root and one or several\n"
- "\"types\", each with a set of \"instances\". (The vtable-vtable should be\n"
- "compared to the class <class> which is the class of itself.)\n\n"
- "@lisp\n"
- "(define ball-root (make-vtable-vtable \"pr\" 0))\n\n"
- "(define (make-ball-type ball-color)\n"
- " (make-struct ball-root 0\n"
- " (make-struct-layout \"pw\")\n"
- " (lambda (ball port)\n"
- " (format port \"#<a ~A ball owned by ~A>\"\n"
- " (color ball)\n"
- " (owner ball)))\n"
- " ball-color))\n"
- "(define (color ball) (struct-ref (struct-vtable ball) vtable-offset-user))\n"
- "(define (owner ball) (struct-ref ball 0))\n\n"
- "(define red (make-ball-type 'red))\n"
- "(define green (make-ball-type 'green))\n\n"
- "(define (make-ball type owner) (make-struct type 0 owner))\n\n"
- "(define ball (make-ball green 'Nisse))\n"
- "ball @result{} #<a green ball owned by Nisse>\n"
- "@end lisp")
-#define FUNC_NAME s_scm_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 s_scm_make_vtable_vtable
+#define FUNC_NAME "make-vtable-vtable"
{
SCM fields, layout, obj;
size_t basic_size;
#undef FUNC_NAME
-SCM_DEFINE (scm_struct_vtable_tag, "struct-vtable-tag", 1, 0, 0,
- (SCM handle),
- "Return the vtable tag of the structure @var{handle}.")
-#define FUNC_NAME s_scm_struct_vtable_tag
-{
- SCM_VALIDATE_VTABLE (1, handle);
- return scm_from_unsigned_integer
- (((scm_t_bits)SCM_STRUCT_DATA (handle)) >> 3);
-}
-#undef FUNC_NAME
-
/* {Associating names and classes with vtables}
*
* The name of a vtable should probably be stored as a slot. This is
void
scm_init_struct ()
{
+ SCM name;
+
/* 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. */
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_c_define ("<standard-vtable>", scm_standard_vtable_vtable);
+ 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_applicable_struct_vtable_vtable =
scm_make_struct (scm_standard_vtable_vtable, SCM_INUM0,
scm_list_1 (scm_make_struct_layout (required_vtable_fields)));
+ name = scm_from_utf8_symbol ("<applicable-struct-vtable>");
SCM_SET_VTABLE_FLAGS (scm_applicable_struct_vtable_vtable,
SCM_VTABLE_FLAG_APPLICABLE_VTABLE);
- scm_c_define ("<applicable-struct-vtable>", scm_applicable_struct_vtable_vtable);
+ scm_set_struct_vtable_name_x (scm_applicable_struct_vtable_vtable, name);
+ scm_define (name, scm_applicable_struct_vtable_vtable);
scm_applicable_struct_with_setter_vtable_vtable =
scm_make_struct (scm_standard_vtable_vtable, SCM_INUM0,
scm_list_1 (scm_make_struct_layout (required_vtable_fields)));
+ name = scm_from_utf8_symbol ("<applicable-struct-with-setter-vtable>");
+ scm_set_struct_vtable_name_x (scm_applicable_struct_with_setter_vtable_vtable, name);
SCM_SET_VTABLE_FLAGS (scm_applicable_struct_with_setter_vtable_vtable,
SCM_VTABLE_FLAG_APPLICABLE_VTABLE | SCM_VTABLE_FLAG_SETTER_VTABLE);
- scm_c_define ("<applicable-struct-with-setter-vtable>", scm_applicable_struct_with_setter_vtable_vtable);
+ scm_define (name, scm_applicable_struct_with_setter_vtable_vtable);
scm_c_define ("vtable-index-layout", scm_from_int (scm_vtable_index_layout));
scm_c_define ("vtable-index-printer",
HCoop / bpt / guile.git / blobdiff