-/* Copyright (C) 1996,1997,1998,1999,2000,2001, 2003, 2004, 2006, 2007, 2008, 2009, 2010, 2011 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 <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"
#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);
/* 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 (SCM2PTR (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 ret;
}
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"
- "@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"
"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
-
-
-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"
- "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
+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 */
+ SCM layout, obj;
+ size_t basic_size;
+ scm_t_bits v;
- /* 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");
+ 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;
- 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);
+ 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);
- SCM_CRITICAL_SECTION_END;
- scm_struct_init (obj, layout, n_tail, n_init, v);
+ 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);
}
#undef FUNC_NAME
-
SCM_DEFINE (scm_make_vtable, "make-vtable", 1, 1, 0,
(SCM fields, SCM printer),
"Create a vtable, for creating structures with the given\n"
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 vtable, answer = SCM_UNDEFINED;
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);
#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
{
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 ()
{
+ 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. */
GC_REGISTER_DISPLACEMENT (2 * sizeof (scm_t_bits));
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_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_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