summaryrefslogtreecommitdiff
path: root/libguile/struct.c
diff options
context:
space:
mode:
authorJim Blandy <jimb@red-bean.com>1996-07-25 22:56:11 +0000
committerJim Blandy <jimb@red-bean.com>1996-07-25 22:56:11 +0000
commit0f2d19dd46f83f41177f61d585732b32a866d613 (patch)
tree86bf67b8c05d36d8181d393e7d706785a74ee777 /libguile/struct.c
downloadguile-0f2d19dd46f83f41177f61d585732b32a866d613.tar.gz
maintainer changed: was lord, now jimb; first import
Diffstat (limited to 'libguile/struct.c')
-rw-r--r--libguile/struct.c548
1 files changed, 548 insertions, 0 deletions
diff --git a/libguile/struct.c b/libguile/struct.c
new file mode 100644
index 000000000..265c7d4fd
--- /dev/null
+++ b/libguile/struct.c
@@ -0,0 +1,548 @@
+/* Copyright (C) 1996 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, 675 Mass Ave, Cambridge, MA 02139, 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 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.
+ *
+ * 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.
+ */
+
+
+#include <stdio.h>
+#include "_scm.h"
+
+
+
+static SCM required_vtable_fields = SCM_BOOL_F;
+static int struct_num = 0;
+
+
+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),
+ fields, SCM_ARG1, s_struct_make_layout);
+
+ {
+ char * field_desc;
+ int len;
+ int x;
+
+ len = SCM_ROLENGTH (fields);
+ field_desc = SCM_ROCHARS (fields);
+ SCM_ASSERT (!(len & 1), fields, "odd length field specification", s_struct_make_layout);
+
+ for (x = 0; x < len; x += 2)
+ {
+ switch (field_desc[x])
+ {
+ case 'u':
+ case 'p':
+#if 0
+ case 'i':
+ case 'd':
+#endif
+ case 's':
+ break;
+ default:
+ SCM_ASSERT (0, SCM_MAKICHR (field_desc[x]) , "unrecognized field type", s_struct_make_layout);
+ }
+
+ switch (field_desc[x + 1])
+ {
+ case 'w':
+ 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;
+ default:
+ SCM_ASSERT (0, SCM_MAKICHR (field_desc[x]) , "unrecognized ref specification", s_struct_make_layout);
+ }
+#if 0
+ if (field_desc[x] == 'd')
+ {
+ SCM_ASSERT (field_desc[x + 2] == '-', SCM_MAKINUM (x / 2), "missing dash field", s_struct_make_layout);
+ x += 2;
+ goto recheck_ref;
+ }
+#endif
+ }
+ new_sym = SCM_CAR (scm_intern_obarray (field_desc, len, SCM_BOOL_F));
+ }
+ return scm_return_first (new_sym, fields);
+}
+
+
+
+
+#ifdef __STDC__
+static void
+init_struct (SCM handle, SCM tail_elts, SCM inits)
+#else
+static void
+init_struct (handle, tail_elts, inits)
+ SCM handle;
+ SCM tail_elts;
+ SCM inits;
+#endif
+{
+ SCM layout;
+ SCM * data;
+ unsigned char * fields_desc;
+ int n_fields;
+ SCM * mem;
+
+ layout = SCM_STRUCT_LAYOUT (handle);
+ data = SCM_STRUCT_DATA (handle);
+ fields_desc = (unsigned char *)SCM_CHARS (layout);
+ n_fields = SCM_LENGTH (layout) / 2;
+ mem = SCM_STRUCT_DATA (handle);
+ while (n_fields)
+ {
+ switch (*fields_desc)
+ {
+#if 0
+ case 'i':
+ if ( ((fields_desc[1] != 'r') && (fields_desc[1] != 'w'))
+ || ((inits == SCM_EOL) || !SCM_NUMBERP (SCM_CAR (inits))))
+ *mem = 0;
+ else
+ {
+ *mem = scm_num2long (SCM_CAR (inits), SCM_ARGn, "init_struct");
+ inits = SCM_CDR (inits);
+ }
+ break;
+#endif
+
+ case 'u':
+ if ( ((fields_desc[1] != 'r') && (fields_desc[1] != 'w'))
+ || ((inits == SCM_EOL) || !SCM_NUMBERP (SCM_CAR (inits))))
+ *mem = 0;
+ else
+ {
+ *mem = scm_num2ulong (SCM_CAR (inits), SCM_ARGn, "init_struct");
+ inits = SCM_CDR (inits);
+ }
+ break;
+
+ case 'p':
+ if ( ((fields_desc[1] != 'r') && (fields_desc[1] != 'w'))
+ || (inits == SCM_EOL))
+ *mem = SCM_EOL;
+ else
+ {
+ *mem = SCM_CAR (inits);
+ inits = SCM_CDR (inits);
+ }
+
+ break;
+
+#if 0
+ case 'd':
+ if ( ((fields_desc[1] != 'r') && (fields_desc[1] != 'w'))
+ || ((inits == SCM_EOL) || !SCM_NUMBERP (SCM_CAR (inits))))
+ *((double *)mem) = 0.0;
+ else
+ {
+ *mem = scm_num2dbl (SCM_CAR (inits), "init_struct");
+ inits = SCM_CDR (inits);
+ }
+ fields_desc += 2;
+ break;
+#endif
+
+ case 's':
+ *mem = handle;
+ 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_BOOL_F);
+}
+
+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;
+
+ if (SCM_IMP (x))
+ return SCM_BOOL_F;
+
+ if (!SCM_STRUCTP (x))
+ return SCM_BOOL_F;
+
+ layout = SCM_STRUCT_LAYOUT (x);
+
+ if (SCM_LENGTH (layout) < SCM_LENGTH (required_vtable_fields))
+ return SCM_BOOL_F;
+
+ if (strncmp (SCM_CHARS (layout), SCM_CHARS (required_vtable_fields),
+ SCM_LENGTH (required_vtable_fields)))
+ return SCM_BOOL_F;
+
+ mem = SCM_STRUCT_DATA (x);
+
+ if (mem[1] != 0)
+ return SCM_BOOL_F;
+
+ if (SCM_IMP (mem[0]))
+ return SCM_BOOL_F;
+
+ return (SCM_SYMBOLP (mem[0])
+ ? SCM_BOOL_T
+ : SCM_BOOL_F);
+}
+
+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;
+ int tail_elts;
+ SCM * data;
+ SCM handle;
+
+ 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);
+
+ layout = SCM_STRUCT_DATA (vtable)[scm_struct_i_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;
+ SCM_SETCDR (handle, data);
+ SCM_SETCAR (handle, ((SCM)SCM_STRUCT_DATA (vtable)) + 1);
+ 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;
+ int basic_size;
+ int tail_elts;
+ SCM * data;
+ SCM handle;
+
+ 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);
+
+
+ fields = scm_string_append (scm_listify (required_vtable_fields,
+ extra_fields,
+ SCM_UNDEFINED));
+ layout = scm_make_struct_layout (fields);
+ 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;
+ SCM_SETCDR (handle, data);
+ SCM_SETCAR (handle, ((SCM)data) + 1);
+ SCM_STRUCT_LAYOUT (handle) = layout;
+ init_struct (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 * data;
+ SCM layout;
+ int p;
+ int n_fields;
+ unsigned char * fields_desc;
+ unsigned char field_type;
+
+
+ SCM_ASSERT (SCM_NIMP (handle) && SCM_STRUCTP (handle), handle,
+ SCM_ARG1, s_struct_ref);
+ SCM_ASSERT (SCM_INUMP (pos), pos, SCM_ARG2, s_struct_ref);
+
+ layout = SCM_STRUCT_LAYOUT (handle);
+ data = SCM_STRUCT_DATA (handle);
+ 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);
+
+ 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);
+ }
+ }
+ switch (field_type)
+ {
+ case 'u':
+ answer = scm_ulong2num (data[p]);
+ break;
+
+#if 0
+ case 'i':
+ answer = scm_long2num (data[p]);
+ break;
+
+ case 'd':
+ answer = scm_makdbl (*((double *)&(data[p])), 0.0);
+ break;
+#endif
+
+ case 's':
+ case 'p':
+ answer = data[p];
+ break;
+
+
+ default:
+ SCM_ASSERT (0, SCM_MAKICHR (field_type), "unrecognized field type", s_struct_ref);
+ break;
+ }
+
+ return answer;
+}
+
+
+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;
+
+
+
+ SCM_ASSERT (SCM_NIMP (handle) && SCM_STRUCTP (handle), handle,
+ SCM_ARG1, s_struct_ref);
+ SCM_ASSERT (SCM_INUMP (pos), pos, SCM_ARG2, s_struct_ref);
+
+ layout = SCM_STRUCT_LAYOUT (handle);
+ data = SCM_STRUCT_DATA (handle);
+ 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_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);
+ }
+ switch (field_type)
+ {
+ case 'u':
+ data[p] = (SCM)scm_num2ulong (val, (char *)SCM_ARG3, s_struct_set_x);
+ break;
+
+#if 0
+ case 'i':
+ data[p] = scm_num2long (val, (char *)SCM_ARG3, s_struct_set_x);
+ break;
+
+ case 'd':
+ *((double *)&(data[p])) = scm_num2dbl (val, (char *)SCM_ARG3);
+ break;
+#endif
+
+ case 'p':
+ data[p] = val;
+ break;
+
+ case 's':
+ SCM_ASSERT (0, SCM_MAKICHR (field_type), "self fields immutable", s_struct_set_x);
+ break;
+
+ default:
+ SCM_ASSERT (0, SCM_MAKICHR (field_type), "unrecognized field type", s_struct_set_x);
+ break;
+ }
+
+ return val;
+}
+
+
+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);
+ return SCM_STRUCT_VTABLE (handle);
+}
+
+
+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);
+ return scm_long2num (SCM_STRUCT_DATA (handle)[-1]);
+}
+
+
+
+
+#ifdef __STDC__
+void
+scm_init_struct (void)
+#else
+void
+scm_init_struct ()
+#endif
+{
+ required_vtable_fields = SCM_CAR (scm_intern_obarray ("pruosr", sizeof ("pruosr") - 1, SCM_BOOL_F));
+ scm_permanent_object (required_vtable_fields);
+ scm_sysintern ("struct-vtable-offset", SCM_MAKINUM (scm_struct_i_vtable_offset));
+#include "struct.x"
+}
+