-/* Copyright (C) 1996,1997,1998,1999,2000,2001 Free Software Foundation, Inc.
+/* Copyright (C) 1996,1997,1998,1999,2000,2001, 2003 Free Software Foundation, Inc.
*
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU General Public License as published by
- * the Free Software Foundation; either version 2, or (at your option)
- * any later version.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with this software; see the file COPYING. If not, write to
- * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
- * Boston, MA 02111-1307 USA
- *
- * As a special exception, the Free Software Foundation gives permission
- * for additional uses of the text contained in its release of GUILE.
- *
- * The exception is that, if you link the GUILE library with other files
- * to produce an executable, this does not by itself cause the
- * resulting executable to be covered by the GNU General Public License.
- * Your use of that executable is in no way restricted on account of
- * linking the GUILE library code into it.
+ * This library is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU Lesser General Public
+ * License as published by the Free Software Foundation; either
+ * version 2.1 of the License, or (at your option) any later version.
*
- * This exception does not however invalidate any other reasons why
- * the executable file might be covered by the GNU General Public License.
- *
- * This exception applies only to the code released by the
- * Free Software Foundation under the name GUILE. If you copy
- * code from other Free Software Foundation releases into a copy of
- * GUILE, as the General Public License permits, the exception does
- * not apply to the code that you add in this way. To avoid misleading
- * anyone as to the status of such modified files, you must delete
- * this exception notice from them.
+ * This library is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ * Lesser General Public License for more details.
*
- * If you write modifications of your own for GUILE, it is your choice
- * whether to permit this exception to apply to your modifications.
- * If you do not wish that, delete this exception notice. */
-
-/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999,
- gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */
+ * You should have received a copy of the GNU Lesser General Public
+ * License along with this library; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
+ */
\f
+#if HAVE_CONFIG_H
+# include <config.h>
+#endif
#include "libguile/_scm.h"
#include "libguile/chars.h"
"type, the second a field protection. Allowed types are 'p' for\n"
"GC-protected Scheme data, 'u' for unprotected binary data, and 's' for\n"
"a field that points to the structure itself. Allowed protections\n"
- "are 'w' for mutable fields, 'r' for read-only fields, and 'o' for opaque \n"
+ "are 'w' for mutable fields, 'r' for read-only fields, and 'o' for opaque\n"
"fields. The last field protection specification may be capitalized to\n"
"indicate that the field is a tail-array.")
#define FUNC_NAME s_scm_make_struct_layout
SCM_DEFINE (scm_struct_p, "struct?", 1, 0, 0,
(SCM x),
- "Return @code{#t} iff @var{obj} is a structure object, else\n"
+ "Return @code{#t} iff @var{x} is a structure object, else\n"
"@code{#f}.")
#define FUNC_NAME s_scm_struct_p
{
SCM_DEFINE (scm_struct_vtable_p, "struct-vtable?", 1, 0, 0,
(SCM x),
- "Return @code{#t} iff obj is a vtable structure.")
+ "Return @code{#t} iff @var{x} is a vtable structure.")
#define FUNC_NAME s_scm_struct_vtable_p
{
SCM layout;
mem = SCM_STRUCT_DATA (x);
- if (mem[1] != 0)
- return SCM_BOOL_F;
-
- return SCM_BOOL (SCM_SYMBOLP (SCM_PACK (mem[0])));
+ return SCM_BOOL (SCM_SYMBOLP (SCM_PACK (mem[scm_vtable_index_layout])));
}
#undef FUNC_NAME
scm_t_bits *
-scm_alloc_struct (int n_words, int n_extra, char *who)
+scm_alloc_struct (int n_words, int n_extra, const char *what)
{
int size = sizeof (scm_t_bits) * (n_words + n_extra) + 7;
- void * block = scm_must_malloc (size, who);
+ void * block = scm_gc_malloc (size, what);
/* Adjust the pointer to hide the extra words. */
scm_t_bits * p = (scm_t_bits *) block + n_extra;
return p;
}
-size_t
+void
scm_struct_free_0 (scm_t_bits * vtable SCM_UNUSED,
scm_t_bits * data SCM_UNUSED)
{
- return 0;
}
-size_t
+void
scm_struct_free_light (scm_t_bits * vtable, scm_t_bits * data)
{
- scm_must_free (data);
- return vtable [scm_struct_i_size] & ~SCM_STRUCTF_MASK;
+ size_t n = vtable [scm_struct_i_size] & ~SCM_STRUCTF_MASK;
+ scm_gc_free (data, n, "struct");
}
-size_t
+void
scm_struct_free_standard (scm_t_bits * vtable SCM_UNUSED, scm_t_bits * data)
{
size_t n = (data[scm_struct_i_n_words] + scm_struct_n_extra_words)
* sizeof (scm_t_bits) + 7;
- scm_must_free ((void *) data[scm_struct_i_ptr]);
- return n;
+ scm_gc_free ((void *) data[scm_struct_i_ptr], n, "heavy struct");
}
-size_t
+void
scm_struct_free_entity (scm_t_bits * vtable SCM_UNUSED, scm_t_bits * data)
{
size_t n = (data[scm_struct_i_n_words] + scm_struct_entity_n_extra_words)
* sizeof (scm_t_bits) + 7;
- scm_must_free ((void *) data[scm_struct_i_ptr]);
- return n;
+ scm_gc_free ((void *) data[scm_struct_i_ptr], n, "entity struct");
}
static void *
void *dummy2 SCM_UNUSED,
void *dummy3 SCM_UNUSED)
{
- scm_structs_to_free = SCM_EOL;
+ scm_i_structs_to_free = SCM_EOL;
return 0;
}
void *dummy2 SCM_UNUSED,
void *dummy3 SCM_UNUSED)
{
- SCM newchain = scm_structs_to_free;
+ SCM newchain = scm_i_structs_to_free;
do
{
/* Mark vtables in GC chain. GC mark set means delay freeing. */
{
SCM vtable = SCM_STRUCT_VTABLE (chain);
if (SCM_STRUCT_GC_CHAIN (vtable) != 0 && vtable != chain)
- SCM_SETGCMARK (vtable);
+ SCM_SET_GC_MARK (vtable);
chain = SCM_STRUCT_GC_CHAIN (chain);
}
/* Free unmarked structs. */
{
SCM obj = chain;
chain = SCM_STRUCT_GC_CHAIN (chain);
- if (SCM_GCMARKP (obj))
+ if (SCM_GC_MARK_P (obj))
{
- SCM_CLRGCMARK (obj);
+ SCM_CLEAR_GC_MARK (obj);
SCM_SET_STRUCT_GC_CHAIN (obj, newchain);
newchain = obj;
}
else
{
- scm_t_bits word0 = SCM_CELL_WORD_0 (obj) - scm_tc3_cons_gloc;
- /* access as struct */
+ /* XXX - use less explicit code. */
+ scm_t_bits word0 = SCM_CELL_WORD_0 (obj) - scm_tc3_struct;
scm_t_bits * vtable_data = (scm_t_bits *) word0;
scm_t_bits * data = SCM_STRUCT_DATA (obj);
scm_t_struct_free free_struct_data
scm_t_bits * data;
SCM handle;
- SCM_VALIDATE_VTABLE (1,vtable);
- SCM_VALIDATE_INUM (2,tail_array_size);
+ SCM_VALIDATE_VTABLE (1, vtable);
+ SCM_VALIDATE_INUM (2, tail_array_size);
SCM_VALIDATE_REST_ARGUMENT (init);
layout = SCM_PACK (SCM_STRUCT_DATA (vtable) [scm_vtable_index_layout]);
basic_size = SCM_SYMBOL_LENGTH (layout) / 2;
tail_elts = SCM_INUM (tail_array_size);
- SCM_NEWCELL2 (handle);
SCM_DEFER_INTS;
if (SCM_STRUCT_DATA (vtable)[scm_struct_i_flags] & SCM_STRUCTF_ENTITY)
{
data = scm_alloc_struct (basic_size + tail_elts,
scm_struct_entity_n_extra_words,
- "make-struct");
+ "entity struct");
data[scm_struct_i_procedure] = SCM_UNPACK (SCM_BOOL_F);
data[scm_struct_i_setter] = SCM_UNPACK (SCM_BOOL_F);
}
else
data = scm_alloc_struct (basic_size + tail_elts,
scm_struct_n_extra_words,
- "make-struct");
- SCM_SET_CELL_WORD_1 (handle, data);
- SCM_SET_STRUCT_GC_CHAIN (handle, 0);
+ "struct");
+ handle = scm_double_cell ((((scm_t_bits) SCM_STRUCT_DATA (vtable))
+ + scm_tc3_struct),
+ (scm_t_bits) data, 0, 0);
scm_struct_init (handle, layout, data, tail_elts, init);
- SCM_SET_CELL_WORD_0 (handle, (scm_t_bits) SCM_STRUCT_DATA (vtable) + scm_tc3_cons_gloc);
SCM_ALLOW_INTS;
return handle;
}
"(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\n")
+ "@end lisp")
#define FUNC_NAME s_scm_make_vtable_vtable
{
SCM fields;
layout = scm_make_struct_layout (fields);
basic_size = SCM_SYMBOL_LENGTH (layout) / 2;
tail_elts = SCM_INUM (tail_array_size);
- SCM_NEWCELL2 (handle);
SCM_DEFER_INTS;
data = scm_alloc_struct (basic_size + tail_elts,
scm_struct_n_extra_words,
- "make-vtable-vtable");
- SCM_SET_CELL_WORD_1 (handle, data);
- SCM_SET_STRUCT_GC_CHAIN (handle, 0);
+ "struct");
+ handle = scm_double_cell ((scm_t_bits) data + scm_tc3_struct,
+ (scm_t_bits) data, 0, 0);
data [scm_vtable_index_layout] = SCM_UNPACK (layout);
scm_struct_init (handle, layout, data, tail_elts, scm_cons (layout, init));
- SCM_SET_CELL_WORD_0 (handle, (scm_t_bits) data + scm_tc3_cons_gloc);
SCM_ALLOW_INTS;
return handle;
}
SCM_DEFINE (scm_struct_ref, "struct-ref", 2, 0, 0,
(SCM handle, SCM pos),
- "@deffnx primitive struct-set! struct n value\n"
+ "@deffnx {Scheme Procedure} struct-set! struct n value\n"
"Access (or modify) 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"
char field_type = 0;
- SCM_VALIDATE_STRUCT (1,handle);
- SCM_VALIDATE_INUM (2,pos);
+ SCM_VALIDATE_STRUCT (1, handle);
+ SCM_VALIDATE_INUM (2, pos);
layout = SCM_STRUCT_LAYOUT (handle);
data = SCM_STRUCT_DATA (handle);
fields_desc = SCM_SYMBOL_CHARS (layout);
n_fields = data[scm_struct_i_n_words];
- SCM_ASSERT_RANGE(1,pos, p < n_fields);
+ SCM_ASSERT_RANGE(1, pos, p < n_fields);
if (p * 2 < SCM_SYMBOL_LENGTH (layout))
{
char * fields_desc;
char field_type = 0;
- SCM_VALIDATE_STRUCT (1,handle);
- SCM_VALIDATE_INUM (2,pos);
+ SCM_VALIDATE_STRUCT (1, handle);
+ SCM_VALIDATE_INUM (2, pos);
layout = SCM_STRUCT_LAYOUT (handle);
data = SCM_STRUCT_DATA (handle);
fields_desc = SCM_SYMBOL_CHARS (layout);
n_fields = data[scm_struct_i_n_words];
- SCM_ASSERT_RANGE (1,pos, p < n_fields);
+ SCM_ASSERT_RANGE (1, pos, p < n_fields);
if (p * 2 < SCM_SYMBOL_LENGTH (layout))
{
"Return the vtable structure that describes the type of @var{struct}.")
#define FUNC_NAME s_scm_struct_vtable
{
- SCM_VALIDATE_STRUCT (1,handle);
+ SCM_VALIDATE_STRUCT (1, handle);
return SCM_STRUCT_VTABLE (handle);
}
#undef FUNC_NAME
"Return the vtable tag of the structure @var{handle}.")
#define FUNC_NAME s_scm_struct_vtable_tag
{
- SCM_VALIDATE_VTABLE (1,handle);
+ SCM_VALIDATE_VTABLE (1, handle);
return scm_long2num ((long) SCM_STRUCT_DATA (handle) >> 3);
}
#undef FUNC_NAME
"Return the name of the vtable @var{vtable}.")
#define FUNC_NAME s_scm_struct_vtable_name
{
- SCM_VALIDATE_VTABLE (1,vtable);
+ SCM_VALIDATE_VTABLE (1, vtable);
return SCM_STRUCT_TABLE_NAME (SCM_CDR (scm_struct_create_handle (vtable)));
}
#undef FUNC_NAME
"Set the name of the vtable @var{vtable} to @var{name}.")
#define FUNC_NAME s_scm_set_struct_vtable_name_x
{
- SCM_VALIDATE_VTABLE (1,vtable);
- SCM_VALIDATE_SYMBOL (2,name);
+ SCM_VALIDATE_VTABLE (1, vtable);
+ SCM_VALIDATE_SYMBOL (2, name);
SCM_SET_STRUCT_TABLE_NAME (SCM_CDR (scm_struct_create_handle (vtable)),
name);
return SCM_UNSPECIFIED;
void
scm_struct_prehistory ()
{
- scm_c_hook_add (&scm_before_mark_c_hook, scm_struct_gc_init, 0, 0);
- scm_c_hook_add (&scm_after_sweep_c_hook, scm_free_structs, 0, 0);
+ scm_i_structs_to_free = SCM_EOL;
+ scm_c_hook_add (&scm_before_sweep_c_hook, scm_struct_gc_init, 0, 0);
+ /* With the new lazy sweep GC, the point at which the entire heap is
+ swept is just before the mark phase. */
+ scm_c_hook_add (&scm_before_mark_c_hook, scm_free_structs, 0, 0);
}
void
{
scm_struct_table
= scm_permanent_object (scm_make_weak_key_hash_table (SCM_MAKINUM (31)));
- required_vtable_fields = scm_makfrom0str ("pruosrpw");
+ required_vtable_fields = scm_makfrom0str ("prsrpw");
scm_permanent_object (required_vtable_fields);
scm_c_define ("vtable-index-layout", SCM_MAKINUM (scm_vtable_index_layout));
scm_c_define ("vtable-index-vtable", SCM_MAKINUM (scm_vtable_index_vtable));
scm_c_define ("vtable-index-printer",
SCM_MAKINUM (scm_vtable_index_printer));
scm_c_define ("vtable-offset-user", SCM_MAKINUM (scm_vtable_offset_user));
-#ifndef SCM_MAGIC_SNARFER
#include "libguile/struct.x"
-#endif
}
/*
HCoop / bpt / guile.git / blobdiff