-/* Copyright (C) 1996 Free Software Foundation, Inc.
+/* Copyright (C) 1996, 1997, 1998 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
*
* 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, 675 Mass Ave, Cambridge, MA 02139, USA.
+ * 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.
*
* 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.
- */
+ * If you do not wish that, delete this exception notice. */
\f
#include <stdio.h>
#include "_scm.h"
#include "chars.h"
+#include "genio.h"
+#include "eval.h"
+#include "alist.h"
+#include "weaks.h"
+#include "hashtab.h"
#include "struct.h"
static SCM required_vtable_fields = SCM_BOOL_F;
static int struct_num = 0;
+SCM scm_struct_table;
\f
SCM_PROC (s_struct_make_layout, "make-struct-layout", 1, 0, 0, scm_make_struct_layout);
-#ifdef __STDC__
-SCM
-scm_make_struct_layout (SCM fields)
-#else
+
SCM
scm_make_struct_layout (fields)
SCM fields;
-#endif
{
SCM new_sym;
SCM_ASSERT (SCM_NIMP (fields) && SCM_ROSTRINGP (fields),
\f
-#ifdef __STDC__
-static void
-init_struct (SCM handle, int tail_elts, SCM inits)
-#else
-static void
-init_struct (handle, tail_elts, inits)
+
+void
+scm_struct_init (handle, tail_elts, inits)
SCM handle;
int tail_elts;
SCM inits;
-#endif
{
SCM layout;
SCM * data;
unsigned char * fields_desc;
- unsigned char prot;
+ unsigned char prot = 0;
int n_fields;
SCM * mem;
int tailp = 0;
*mem = 0;
else
{
- *mem = scm_num2long (SCM_CAR (inits), SCM_ARGn, "init_struct");
+ *mem = scm_num2long (SCM_CAR (inits), SCM_ARGn, "scm_struct_init");
inits = SCM_CDR (inits);
}
break;
*mem = 0;
else
{
- *mem = scm_num2ulong (SCM_CAR (inits), SCM_ARGn, "init_struct");
+ *mem = scm_num2ulong (SCM_CAR (inits), SCM_ARGn, "scm_struct_init");
inits = SCM_CDR (inits);
}
break;
case 'p':
if ((prot != 'r' && prot != 'w') || inits == SCM_EOL)
- *mem = SCM_EOL;
+ *mem = SCM_BOOL_F;
else
{
*mem = SCM_CAR (inits);
*((double *)mem) = 0.0;
else
{
- *mem = scm_num2dbl (SCM_CAR (inits), "init_struct");
+ *mem = scm_num2dbl (SCM_CAR (inits), "scm_struct_init");
inits = SCM_CDR (inits);
}
fields_desc += 2;
SCM_PROC (s_struct_p, "struct?", 1, 0, 0, scm_struct_p);
-#ifdef __STDC__
-SCM
-scm_struct_p (SCM x)
-#else
+
SCM
scm_struct_p (x)
SCM x;
-#endif
{
return ((SCM_NIMP (x) && SCM_STRUCTP (x))
? SCM_BOOL_T
}
SCM_PROC (s_struct_vtable_p, "struct-vtable?", 1, 0, 0, scm_struct_vtable_p);
-#ifdef __STDC__
-SCM
-scm_struct_vtable_p (SCM x)
-#else
+
SCM
scm_struct_vtable_p (x)
SCM x;
-#endif
{
SCM layout;
SCM * mem;
: SCM_BOOL_F);
}
+
+/* All struct data must be allocated at an address whose bottom three
+ bits are zero. This is because the tag for a struct lives in the
+ bottom three bits of the struct's car, and the upper bits point to
+ the data of its vtable, which is a struct itself. Thus, if the
+ address of that data doesn't end in three zeros, tagging it will
+ destroy the pointer.
+
+ This function allocates a block of memory, and returns a pointer at
+ least scm_struct_n_extra_words words into the block. Furthermore,
+ it guarantees that that pointer's least three significant bits are
+ all zero.
+
+ The argument n_words should be the number of words that should
+ appear after the returned address. (That is, it shouldn't include
+ scm_struct_n_extra_words.)
+
+ This function initializes the following fields of the struct:
+
+ scm_struct_i_ptr --- the actual stort of the block of memory; the
+ address you should pass to 'free' to dispose of the block.
+ This field allows us to both guarantee that the returned
+ address is divisible by eight, and allow the GC to free the
+ block.
+
+ scm_struct_i_n_words --- the number of words allocated to the
+ block, including the extra fields. This is used by the GC.
+
+ scm_struct_i_tag --- a unique tag assigned to this struct,
+ allocated according to struct_num.
+
+ Ugh. */
+
+
+SCM *
+scm_alloc_struct (int n_words, int n_extra, char *who)
+{
+ int size = sizeof (SCM) * (n_words + n_extra) + 7;
+ SCM *block = (SCM *) scm_must_malloc (size, who);
+
+ /* Adjust the pointer to hide the extra words. */
+ SCM *p = block + n_extra;
+
+ /* Adjust it even further so it's aligned on an eight-byte boundary. */
+ p = (SCM *) (((SCM) p + 7) & ~7);
+
+ /* Initialize a few fields as described above, except for the tag. */
+ p[scm_struct_i_ptr] = (SCM) block;
+ p[scm_struct_i_n_words] = (SCM) (n_words + n_extra);
+
+ return p;
+}
+
+
SCM_PROC (s_make_struct, "make-struct", 2, 0, 1, scm_make_struct);
-#ifdef __STDC__
-SCM
-scm_make_struct (SCM vtable, SCM tail_array_size, SCM init)
-#else
+
SCM
scm_make_struct (vtable, tail_array_size, init)
SCM vtable;
SCM tail_array_size;
SCM init;
-#endif
{
SCM layout;
int basic_size;
SCM_ASSERT ((SCM_BOOL_F != scm_struct_vtable_p (vtable)),
vtable, SCM_ARG1, s_make_struct);
- SCM_ASSERT (SCM_INUMP (tail_array_size), tail_array_size, SCM_ARG2, s_make_struct);
+ SCM_ASSERT (SCM_INUMP (tail_array_size), tail_array_size, SCM_ARG2,
+ s_make_struct);
- layout = SCM_STRUCT_DATA (vtable)[scm_struct_i_layout];
+ layout = SCM_STRUCT_DATA (vtable)[scm_vtable_index_layout];
basic_size = SCM_LENGTH (layout) / 2;
tail_elts = SCM_INUM (tail_array_size);
SCM_NEWCELL (handle);
SCM_DEFER_INTS;
- data = (SCM*)scm_must_malloc (sizeof (SCM) * (scm_struct_n_extra_words
- + basic_size
- + tail_elts),
- "structure");
- data += scm_struct_n_extra_words;
- data[scm_struct_i_n_words] = (SCM) (scm_struct_n_extra_words
- + basic_size
- + tail_elts);
+ 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");
+ data[scm_struct_i_proc + 0] = SCM_BOOL_F;
+ data[scm_struct_i_proc + 1] = SCM_BOOL_F;
+ data[scm_struct_i_proc + 2] = SCM_BOOL_F;
+ data[scm_struct_i_proc + 3] = SCM_BOOL_F;
+ data[scm_struct_i_setter] = SCM_BOOL_F;
+ }
+ else
+ data = scm_alloc_struct (basic_size + tail_elts,
+ scm_struct_n_extra_words,
+ "make-struct");
data[scm_struct_i_tag] = struct_num++;
SCM_SETCDR (handle, data);
SCM_SETCAR (handle, ((SCM)SCM_STRUCT_DATA (vtable)) + scm_tc3_cons_gloc);
- init_struct (handle, tail_elts, init);
+ scm_struct_init (handle, tail_elts, init);
SCM_ALLOW_INTS;
return handle;
}
SCM_PROC (s_make_vtable_vtable, "make-vtable-vtable", 2, 0, 1, scm_make_vtable_vtable);
-#ifdef __STDC__
-SCM
-scm_make_vtable_vtable (SCM extra_fields, SCM tail_array_size, SCM init)
-#else
+
SCM
scm_make_vtable_vtable (extra_fields, tail_array_size, init)
SCM extra_fields;
SCM tail_array_size;
SCM init;
-#endif
{
SCM fields;
SCM layout;
SCM_ASSERT (SCM_NIMP (extra_fields) && SCM_ROSTRINGP (extra_fields),
extra_fields, SCM_ARG1, s_make_vtable_vtable);
- SCM_ASSERT (SCM_INUMP (tail_array_size), tail_array_size, SCM_ARG3, s_make_vtable_vtable);
-
+ SCM_ASSERT (SCM_INUMP (tail_array_size), tail_array_size, SCM_ARG2,
+ s_make_vtable_vtable);
fields = scm_string_append (scm_listify (required_vtable_fields,
extra_fields,
tail_elts = SCM_INUM (tail_array_size);
SCM_NEWCELL (handle);
SCM_DEFER_INTS;
- data = (SCM *) scm_must_malloc (sizeof (SCM) * (scm_struct_n_extra_words
- + basic_size
- + tail_elts),
- "structure");
- data += scm_struct_n_extra_words;
- data[scm_struct_i_n_words] = (SCM) (scm_struct_n_extra_words
- + basic_size
- + tail_elts);
+ data = scm_alloc_struct (basic_size + tail_elts,
+ scm_struct_n_extra_words,
+ "make-vtable-vtable");
data[scm_struct_i_tag] = struct_num++;
SCM_SETCDR (handle, data);
SCM_SETCAR (handle, ((SCM)data) + scm_tc3_cons_gloc);
SCM_STRUCT_LAYOUT (handle) = layout;
- init_struct (handle, tail_elts, scm_cons (layout, init));
+ scm_struct_init (handle, tail_elts, scm_cons (layout, init));
SCM_ALLOW_INTS;
return handle;
}
SCM_PROC (s_struct_ref, "struct-ref", 2, 0, 0, scm_struct_ref);
-#ifdef __STDC__
-SCM
-scm_struct_ref (SCM handle, SCM pos)
-#else
+
SCM
scm_struct_ref (handle, pos)
SCM handle;
SCM pos;
-#endif
{
SCM answer = SCM_UNDEFINED;
SCM * data;
int p;
int n_fields;
unsigned char * fields_desc;
- unsigned char field_type;
+ unsigned char field_type = 0;
SCM_ASSERT (SCM_NIMP (handle) && SCM_STRUCTP (handle), handle,
p = SCM_INUM (pos);
fields_desc = (unsigned char *)SCM_CHARS (layout);
- n_fields = data[- scm_struct_n_extra_words] - scm_struct_n_extra_words;
+ n_fields = data[scm_struct_i_n_words] - scm_struct_n_extra_words;
SCM_ASSERT (p < n_fields, pos, SCM_OUTOFRANGE, s_struct_ref);
else
{
SCM_ASSERT (0, pos, "ref denied", s_struct_ref);
+ abort ();
}
switch (field_type)
SCM_PROC (s_struct_set_x, "struct-set!", 3, 0, 0, scm_struct_set_x);
-#ifdef __STDC__
-SCM
-scm_struct_set_x (SCM handle, SCM pos, SCM val)
-#else
+
SCM
scm_struct_set_x (handle, pos, val)
SCM handle;
SCM pos;
SCM val;
-#endif
{
SCM * data;
SCM layout;
int p;
int n_fields;
unsigned char * fields_desc;
- unsigned char field_type;
+ unsigned char field_type = 0;
p = SCM_INUM (pos);
fields_desc = (unsigned char *)SCM_CHARS (layout);
- n_fields = data[- scm_struct_n_extra_words] - scm_struct_n_extra_words;
+ n_fields = data[scm_struct_i_n_words] - scm_struct_n_extra_words;
SCM_ASSERT (p < n_fields, pos, SCM_OUTOFRANGE, s_struct_set_x);
else
{
SCM_ASSERT (0, pos, "set_x denied", s_struct_ref);
+ abort ();
}
switch (field_type)
SCM_PROC (s_struct_vtable, "struct-vtable", 1, 0, 0, scm_struct_vtable);
-#ifdef __STDC__
-SCM
-scm_struct_vtable (SCM handle)
-#else
+
SCM
scm_struct_vtable (handle)
SCM handle;
-#endif
{
SCM_ASSERT (SCM_NIMP (handle) && SCM_STRUCTP (handle), handle,
SCM_ARG1, s_struct_vtable);
SCM_PROC (s_struct_vtable_tag, "struct-vtable-tag", 1, 0, 0, scm_struct_vtable_tag);
-#ifdef __STDC__
-SCM
-scm_struct_vtable_tag (SCM handle)
-#else
+
SCM
scm_struct_vtable_tag (handle)
SCM handle;
-#endif
{
- SCM_ASSERT (SCM_NIMP (handle) && (SCM_BOOL_F != scm_struct_vtable_p (handle)),
+ SCM_ASSERT (SCM_NFALSEP (scm_struct_vtable_p (handle)),
handle, SCM_ARG1, s_struct_vtable_tag);
- return scm_long2num (SCM_STRUCT_DATA (handle)[-1]);
+ return scm_long2num (SCM_STRUCT_DATA (handle)[scm_struct_i_tag]);
+}
+
+/* {Associating names and classes with vtables}
+ *
+ * The name of a vtable should probably be stored as a slot. This is
+ * a backward compatible solution until agreement has been achieved on
+ * how to associate names with vtables.
+ */
+
+unsigned int
+scm_struct_ihashq (SCM obj, unsigned int n)
+{
+ return (SCM_STRUCT_DATA (obj)[scm_struct_i_tag] & ~SCM_STRUCTF_MASK) % n;
+}
+
+SCM
+scm_struct_create_handle (SCM obj)
+{
+ SCM handle = scm_hash_fn_create_handle_x (scm_struct_table,
+ obj,
+ SCM_BOOL_F,
+ scm_struct_ihashq,
+ scm_sloppy_assq,
+ 0);
+ if (SCM_FALSEP (SCM_CDR (handle)))
+ SCM_SETCDR (handle, scm_cons (SCM_BOOL_F, SCM_BOOL_F));
+ return handle;
+}
+
+SCM_PROC (s_struct_vtable_name, "struct-vtable-name", 1, 0, 0, scm_struct_vtable_name);
+
+SCM
+scm_struct_vtable_name (SCM vtable)
+{
+ SCM_ASSERT (SCM_NFALSEP (scm_struct_vtable_p (vtable)),
+ vtable, SCM_ARG1, s_struct_vtable_name);
+
+ return SCM_STRUCT_TABLE_NAME (SCM_CDR (scm_struct_create_handle (vtable)));
+}
+
+SCM_PROC (s_set_struct_vtable_name_x, "set-struct-vtable-name!", 2, 0, 0, scm_set_struct_vtable_name_x);
+
+SCM
+scm_set_struct_vtable_name_x (SCM vtable, SCM name)
+{
+ SCM_ASSERT (SCM_NIMP (vtable) && SCM_NFALSEP (scm_struct_vtable_p (vtable)),
+ vtable, SCM_ARG1, s_set_struct_vtable_name_x);
+ SCM_ASSERT (SCM_NIMP (name) && SCM_SYMBOLP (name),
+ name, SCM_ARG2, s_set_struct_vtable_name_x);
+ SCM_SET_STRUCT_TABLE_NAME (SCM_CDR (scm_struct_create_handle (vtable)),
+ name);
+ return SCM_UNSPECIFIED;
}
\f
-#ifdef __STDC__
void
-scm_init_struct (void)
-#else
+scm_print_struct (exp, port, pstate)
+ SCM exp;
+ SCM port;
+ scm_print_state *pstate;
+{
+ if (SCM_NFALSEP (scm_procedure_p (SCM_STRUCT_PRINTER (exp))))
+ scm_printer_apply (SCM_STRUCT_PRINTER (exp), exp, port, pstate);
+ else
+ {
+ scm_lfwrite ("#<struct ", sizeof ("#<struct ") - 1, port);
+ scm_intprint (SCM_STRUCT_VTABLE (exp), 16, port);
+ scm_putc (':', port);
+ scm_intprint (exp, 16, port);
+ scm_putc ('>', port);
+ }
+}
+
void
scm_init_struct ()
-#endif
{
- required_vtable_fields = SCM_CAR (scm_intern_obarray ("pruosr", sizeof ("pruosr") - 1, SCM_BOOL_F));
+ scm_struct_table
+ = scm_permanent_object (scm_make_weak_key_hash_table (SCM_MAKINUM (31)));
+ required_vtable_fields = SCM_CAR (scm_intern_obarray ("pruosrpw", sizeof ("pruosrpw") - 1, SCM_BOOL_F));
scm_permanent_object (required_vtable_fields);
- scm_sysintern ("struct-vtable-offset", SCM_MAKINUM (scm_struct_i_vtable_offset));
+ scm_sysintern ("vtable-index-layout", SCM_MAKINUM (scm_vtable_index_layout));
+ scm_sysintern ("vtable-index-vtable", SCM_MAKINUM (scm_vtable_index_vtable));
+ scm_sysintern ("vtable-index-printer", SCM_MAKINUM (scm_vtable_index_printer));
+ scm_sysintern ("vtable-offset-user", SCM_MAKINUM (scm_vtable_offset_user));
#include "struct.x"
}
-
HCoop / bpt / guile.git / blobdiff