-/* Copyright (C) 1996 Free Software Foundation, Inc.
+/* Copyright (C) 1996, 1997 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 "struct.h"
#ifdef HAVE_STRING_H
#include <string.h>
\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),
switch (field_desc[x + 1])
{
case 'w':
- SCM_ASSERT ((field_desc[x] != 's'), SCM_MAKICHR (field_desc[x + 1]),
+ SCM_ASSERT (field_desc[x] != 's', SCM_MAKICHR (field_desc[x + 1]),
"self fields not writable", s_struct_make_layout);
case 'r':
case 'o':
break;
+ case 'R':
+ case 'W':
+ case 'O':
+ SCM_ASSERT (field_desc[x] != 's', SCM_MAKICHR (field_desc[x + 1]),
+ "self fields not allowed in tail array",
+ s_struct_make_layout);
+ SCM_ASSERT (x == len - 2, SCM_MAKICHR (field_desc[x + 1]),
+ "tail array field must be last field in layout",
+ s_struct_make_layout);
+ break;
default:
SCM_ASSERT (0, SCM_MAKICHR (field_desc[x]) , "unrecognized ref specification", s_struct_make_layout);
}
\f
-#ifdef __STDC__
-static void
-init_struct (SCM handle, SCM tail_elts, SCM inits)
-#else
+
+static void init_struct SCM_P ((SCM handle, int tail_elts, SCM inits));
+
static void
init_struct (handle, tail_elts, inits)
SCM handle;
- SCM tail_elts;
+ int tail_elts;
SCM inits;
-#endif
{
SCM layout;
SCM * data;
unsigned char * fields_desc;
+ unsigned char prot = 0;
int n_fields;
SCM * mem;
-
+ int tailp = 0;
+
layout = SCM_STRUCT_LAYOUT (handle);
data = SCM_STRUCT_DATA (handle);
- fields_desc = (unsigned char *)SCM_CHARS (layout);
+ fields_desc = (unsigned char *) SCM_CHARS (layout) - 2;
n_fields = SCM_LENGTH (layout) / 2;
mem = SCM_STRUCT_DATA (handle);
while (n_fields)
{
+ if (!tailp)
+ {
+ fields_desc += 2;
+ prot = fields_desc[1];
+ if (SCM_LAYOUT_TAILP (prot))
+ {
+ tailp = 1;
+ prot = prot == 'R' ? 'r' : prot == 'W' ? 'w' : 'o';
+ *mem++ = tail_elts;
+ n_fields += tail_elts - 1;
+ if (n_fields == 0)
+ break;
+ }
+ }
+
switch (*fields_desc)
{
#if 0
case 'i':
- if ( ((fields_desc[1] != 'r') && (fields_desc[1] != 'w'))
- || ((inits == SCM_EOL) || !SCM_NUMBERP (SCM_CAR (inits))))
+ if ((prot != 'r' && prot != 'w') || inits == SCM_EOL)
*mem = 0;
else
{
#endif
case 'u':
- if ( ((fields_desc[1] != 'r') && (fields_desc[1] != 'w'))
- || ((inits == SCM_EOL) || !SCM_NUMBERP (SCM_CAR (inits))))
+ if ((prot != 'r' && prot != 'w') || inits == SCM_EOL)
*mem = 0;
else
{
break;
case 'p':
- if ( ((fields_desc[1] != 'r') && (fields_desc[1] != 'w'))
- || (inits == SCM_EOL))
- *mem = SCM_EOL;
+ if ((prot != 'r' && prot != 'w') || inits == SCM_EOL)
+ *mem = SCM_BOOL_F;
else
{
*mem = SCM_CAR (inits);
#if 0
case 'd':
- if ( ((fields_desc[1] != 'r') && (fields_desc[1] != 'w'))
- || ((inits == SCM_EOL) || !SCM_NUMBERP (SCM_CAR (inits))))
+ if ((prot != 'r' && prot != 'w') || inits == SCM_EOL)
*((double *)mem) = 0.0;
else
{
break;
}
- fields_desc += 2;
n_fields--;
mem++;
}
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. */
+
+
+static SCM *alloc_struct SCM_P ((int n_words, char *who));
+
+static SCM *
+alloc_struct (n_words, who)
+ int n_words;
+ char *who;
+{
+ int size = sizeof (SCM) * (n_words + scm_struct_n_extra_words) + 7;
+ SCM *block = (SCM *) scm_must_malloc (size, who);
+
+ /* Adjust the pointer to hide the extra words. */
+ SCM *p = block + scm_struct_n_extra_words;
+
+ /* 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. */
+ p[scm_struct_i_ptr] = (SCM) block;
+ p[scm_struct_i_n_words] = (SCM) (scm_struct_n_extra_words + n_words);
+ p[scm_struct_i_tag] = struct_num++;
+
+ 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) * (2 + basic_size + tail_elts), "structure");
- *data = (SCM)(2 + basic_size + tail_elts);
- data[1] = struct_num++;
- data += 2;
+ data = alloc_struct (basic_size + tail_elts, "make-struct");
SCM_SETCDR (handle, data);
- SCM_SETCAR (handle, ((SCM)SCM_STRUCT_DATA (vtable)) + 1);
+ SCM_SETCAR (handle, ((SCM)SCM_STRUCT_DATA (vtable)) + scm_tc3_cons_gloc);
init_struct (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) * (2 + basic_size + tail_elts), "structure");
- *data = (SCM)(2 + basic_size + tail_elts);
- data[1] = struct_num++;
- data += 2;
+ data = alloc_struct (basic_size + tail_elts, "make-vtable-vtable");
SCM_SETCDR (handle, data);
- SCM_SETCAR (handle, ((SCM)data) + 1);
+ SCM_SETCAR (handle, ((SCM)data) + scm_tc3_cons_gloc);
SCM_STRUCT_LAYOUT (handle) = layout;
init_struct (handle, tail_elts, scm_cons (layout, init));
SCM_ALLOW_INTS;
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 answer = SCM_UNDEFINED;
SCM * data;
SCM layout;
int p;
p = SCM_INUM (pos);
fields_desc = (unsigned char *)SCM_CHARS (layout);
- n_fields = SCM_LENGTH (layout) / 2;
-
- SCM_ASSERT (p <= n_fields, pos, SCM_OUTOFRANGE, s_struct_ref);
+ n_fields = data[scm_struct_i_n_words] - scm_struct_n_extra_words;
+
+ SCM_ASSERT (p < n_fields, pos, SCM_OUTOFRANGE, s_struct_ref);
- field_type = fields_desc[p * 2];
- {
- unsigned char ref;
- ref = fields_desc [p * 2 + 1];
- if ((ref != 'r') && (ref != 'w'))
- {
- if ((ref == 'R') || (ref == 'W'))
- field_type = 'u';
- else
- SCM_ASSERT (0, pos, "ref denied", s_struct_ref);
- }
- }
+ if (p * 2 < SCM_LENGTH (layout))
+ {
+ unsigned char ref;
+ field_type = fields_desc[p * 2];
+ ref = fields_desc[p * 2 + 1];
+ if ((ref != 'r') && (ref != 'w'))
+ {
+ if ((ref == 'R') || (ref == 'W'))
+ field_type = 'u';
+ else
+ SCM_ASSERT (0, pos, "ref denied", s_struct_ref);
+ }
+ }
+ else if (fields_desc[SCM_LENGTH (layout) - 1] != 'O')
+ field_type = fields_desc[SCM_LENGTH (layout) - 2];
+ else
+ {
+ SCM_ASSERT (0, pos, "ref denied", s_struct_ref);
+ abort ();
+ }
+
switch (field_type)
{
case 'u':
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;
p = SCM_INUM (pos);
fields_desc = (unsigned char *)SCM_CHARS (layout);
- n_fields = SCM_LENGTH (layout) / 2;
+ 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);
+ SCM_ASSERT (p < n_fields, pos, SCM_OUTOFRANGE, s_struct_set_x);
- field_type = fields_desc[p * 2];
- {
- unsigned char set_x;
- set_x = fields_desc [p * 2 + 1];
- if (set_x != 'w')
- SCM_ASSERT (0, pos, "set_x denied", s_struct_set_x);
- }
+ if (p * 2 < SCM_LENGTH (layout))
+ {
+ unsigned char set_x;
+ field_type = fields_desc[p * 2];
+ set_x = fields_desc [p * 2 + 1];
+ if (set_x != 'w')
+ SCM_ASSERT (0, pos, "set_x denied", s_struct_set_x);
+ }
+ else if (fields_desc[SCM_LENGTH (layout) - 1] == 'W')
+ field_type = fields_desc[SCM_LENGTH (layout) - 2];
+ else
+ {
+ SCM_ASSERT (0, pos, "set_x denied", s_struct_ref);
+ abort ();
+ }
+
switch (field_type)
{
case 'u':
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)),
handle, SCM_ARG1, s_struct_vtable_tag);
\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));
+ 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