X-Git-Url: http://git.hcoop.net/bpt/guile.git/blobdiff_plain/891a1851a1e0e47560cf99cf76e9478d77e1a7db..d8d9a8da05ec876acba81a559798eb5eeceb5a17:/libguile/struct.c?ds=sidebyside diff --git a/libguile/struct.c b/libguile/struct.c index 4a2a9d750..8bfbcf433 100644 --- a/libguile/struct.c +++ b/libguile/struct.c @@ -1,4 +1,5 @@ -/* 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 @@ -24,12 +25,13 @@ #include #include +#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" @@ -151,8 +153,9 @@ SCM_DEFINE (scm_make_struct_layout, "make-struct-layout", 1, 0, 0, #undef FUNC_NAME -/* 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) { @@ -178,13 +181,11 @@ 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; @@ -410,7 +411,7 @@ SCM_DEFINE (scm_struct_vtable_p, "struct-vtable?", 1, 0, 0, /* 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); @@ -443,16 +444,8 @@ scm_i_alloc_struct (scm_t_bits *vtable_data, int n_words) /* 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; } @@ -524,12 +517,48 @@ scm_c_make_struct (SCM vtable, size_t n_tail, size_t n_init, scm_t_bits init, .. 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" @@ -539,8 +568,7 @@ SCM_DEFINE (scm_make_struct, "make-struct", 2, 0, 1, "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; @@ -568,96 +596,28 @@ SCM_DEFINE (scm_make_struct, "make-struct", 2, 0, 1, } #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 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 \"#\"\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{} #\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); @@ -665,7 +625,6 @@ SCM_DEFINE (scm_make_vtable_vtable, "make-vtable-vtable", 2, 0, 1, } #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" @@ -738,10 +697,15 @@ scm_i_struct_equalp (SCM s1, SCM s2) 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; @@ -910,7 +874,8 @@ SCM_DEFINE (scm_struct_set_x, "struct-set!", 3, 0, 0, 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); @@ -919,17 +884,6 @@ SCM_DEFINE (scm_struct_vtable, "struct-vtable", 1, 0, 0, #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 @@ -982,22 +936,22 @@ scm_print_struct (SCM exp, SCM port, scm_print_state *pstate) { 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 */ @@ -1005,25 +959,27 @@ scm_print_struct (SCM exp, SCM port, scm_print_state *pstate) { 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. */ @@ -1035,25 +991,33 @@ scm_init_struct () 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 (""); + 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 (""); SCM_SET_VTABLE_FLAGS (scm_applicable_struct_vtable_vtable, SCM_VTABLE_FLAG_APPLICABLE_VTABLE); - scm_c_define ("", 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 (""); + 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 ("", 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",