-/* Copyright (C) 1996, 1997, 1998 Free Software Foundation, Inc.
+/* Copyright (C) 1996, 97, 98, 99, 2000 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
* 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 */
+
\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 "ports.h"
+#include "strings.h"
+#include "validate.h"
#include "struct.h"
#ifdef HAVE_STRING_H
\f
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);
-
-SCM
-scm_make_struct_layout (fields)
- SCM fields;
+SCM_DEFINE (scm_make_struct_layout, "make-struct-layout", 1, 0, 0,
+ (SCM fields),
+ "Return a new structure layout object.\n\n"
+ "@var{fields} must be a read-only string made up of pairs of characters\n"
+ "strung together. The first character of each pair describes a field\n"
+ "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"
+ "fields that should point to the structure itself. Allowed protections\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 new_sym;
- SCM_ASSERT (SCM_NIMP (fields) && SCM_ROSTRINGP (fields),
- fields, SCM_ARG1, s_struct_make_layout);
-
- {
+ SCM_VALIDATE_ROSTRING (1,fields);
+ { /* scope */
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);
+ SCM_ASSERT (!(len & 1), fields, "odd length field specification", FUNC_NAME);
for (x = 0; x < len; x += 2)
{
case 's':
break;
default:
- SCM_ASSERT (0, SCM_MAKICHR (field_desc[x]) , "unrecognized field type", s_struct_make_layout);
+ SCM_ASSERT (0, SCM_MAKE_CHAR (field_desc[x]) , "unrecognized field type", FUNC_NAME);
}
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);
+ SCM_ASSERT (field_desc[x] != 's', SCM_MAKE_CHAR (field_desc[x + 1]),
+ "self fields not writable", FUNC_NAME);
case 'r':
case 'o':
case 'R':
case 'W':
case 'O':
- SCM_ASSERT (field_desc[x] != 's', SCM_MAKICHR (field_desc[x + 1]),
+ SCM_ASSERT (field_desc[x] != 's', SCM_MAKE_CHAR (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]),
+ FUNC_NAME);
+ SCM_ASSERT (x == len - 2, SCM_MAKE_CHAR (field_desc[x + 1]),
"tail array field must be last field in layout",
- s_struct_make_layout);
+ FUNC_NAME);
break;
default:
- SCM_ASSERT (0, SCM_MAKICHR (field_desc[x]) , "unrecognized ref specification", s_struct_make_layout);
+ SCM_ASSERT (0, SCM_MAKE_CHAR (field_desc[x]) , "unrecognized ref specification", FUNC_NAME);
}
#if 0
if (field_desc[x] == 'd')
{
- SCM_ASSERT (field_desc[x + 2] == '-', SCM_MAKINUM (x / 2), "missing dash field", s_struct_make_layout);
+ SCM_ASSERT (field_desc[x + 2] == '-', SCM_MAKINUM (x / 2), "missing dash field", FUNC_NAME);
x += 2;
goto recheck_ref;
}
}
return scm_return_first (new_sym, fields);
}
+#undef FUNC_NAME
\f
void
-scm_struct_init (handle, tail_elts, inits)
- SCM handle;
- int tail_elts;
- SCM inits;
+scm_struct_init (SCM handle, int tail_elts, SCM inits)
{
SCM layout;
SCM * data;
{
tailp = 1;
prot = prot == 'R' ? 'r' : prot == 'W' ? 'w' : 'o';
- *mem++ = tail_elts;
+ *mem++ = SCM_PACK (tail_elts);
n_fields += tail_elts - 1;
if (n_fields == 0)
break;
*mem = 0;
else
{
- *mem = scm_num2ulong (SCM_CAR (inits), SCM_ARGn, "scm_struct_init");
+ *mem = SCM_PACK (scm_num2ulong (SCM_CAR (inits),
+ SCM_ARGn,
+ "scm_struct_init"));
inits = SCM_CDR (inits);
}
break;
}
-SCM_PROC (s_struct_p, "struct?", 1, 0, 0, scm_struct_p);
-
-SCM
-scm_struct_p (x)
- SCM x;
+SCM_DEFINE (scm_struct_p, "struct?", 1, 0, 0,
+ (SCM x),
+ "Return #t iff @var{obj} is a structure object, else #f.")
+#define FUNC_NAME s_scm_struct_p
{
- return ((SCM_NIMP (x) && SCM_STRUCTP (x))
- ? SCM_BOOL_T
- : SCM_BOOL_F);
+ return SCM_BOOL(SCM_STRUCTP (x));
}
+#undef FUNC_NAME
-SCM_PROC (s_struct_vtable_p, "struct-vtable?", 1, 0, 0, scm_struct_vtable_p);
-
-SCM
-scm_struct_vtable_p (x)
- SCM x;
+SCM_DEFINE (scm_struct_vtable_p, "struct-vtable?", 1, 0, 0,
+ (SCM x),
+ "Return #t iff obj is a vtable structure.")
+#define FUNC_NAME s_scm_struct_vtable_p
{
SCM layout;
SCM * mem;
if (SCM_IMP (mem[0]))
return SCM_BOOL_F;
- return (SCM_SYMBOLP (mem[0])
- ? SCM_BOOL_T
- : SCM_BOOL_F);
+ return SCM_BOOL(SCM_SYMBOLP (mem[0]));
}
+#undef FUNC_NAME
/* All struct data must be allocated at an address whose bottom three
This function initializes the following fields of the struct:
- scm_struct_i_ptr --- the actual stort of the block of memory; the
+ scm_struct_i_ptr --- the actual start 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
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 *p = block + n_extra;
/* Adjust it even further so it's aligned on an eight-byte boundary. */
- p = (SCM *) (((SCM) p + 7) & ~7);
+ p = (SCM *) (((scm_bits_t) SCM_UNPACK (p) + 7) & ~7);
/* Initialize a few fields as described above. */
+ p[scm_struct_i_free] = (SCM) scm_struct_free_standard;
p[scm_struct_i_ptr] = (SCM) block;
- p[scm_struct_i_n_words] = (SCM) (n_words + n_extra);
- p[scm_struct_i_tag] = struct_num++;
+ p[scm_struct_i_n_words] = (SCM) n_words;
+ p[scm_struct_i_flags] = 0;
return p;
}
+scm_sizet
+scm_struct_free_0 (SCM *vtable, SCM *data)
+{
+ return 0;
+}
+
+scm_sizet
+scm_struct_free_light (SCM *vtable, SCM *data)
+{
+ free (data);
+ return SCM_UNPACK (vtable[scm_struct_i_size]) & ~SCM_STRUCTF_MASK;
+}
-SCM_PROC (s_make_struct, "make-struct", 2, 0, 1, scm_make_struct);
+scm_sizet
+scm_struct_free_standard (SCM *vtable, SCM *data)
+{
+ size_t n = ((SCM_UNPACK (data[scm_struct_i_n_words]) + scm_struct_n_extra_words)
+ * sizeof (SCM) + 7);
+ free ((void *) data[scm_struct_i_ptr]);
+ return n;
+}
-SCM
-scm_make_struct (vtable, tail_array_size, init)
- SCM vtable;
- SCM tail_array_size;
- SCM init;
+scm_sizet
+scm_struct_free_entity (SCM *vtable, SCM *data)
+{
+ size_t n = (SCM_UNPACK(data[scm_struct_i_n_words] + scm_struct_entity_n_extra_words)
+ * sizeof (SCM) + 7);
+ free ((void *) data[scm_struct_i_ptr]);
+ return n;
+}
+
+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 (@xref{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"
+ "this is the number of elements allocated to that array.\n\n"
+ "The @var{inits} are optional arguments describing how successive fields\n"
+ "of the structure should be initialized. Only fields with protection 'r'\n"
+ "or 'w' can be initialized -- fields of protection 's' are automatically\n"
+ "initialized to point to the new structure itself; fields of protection 'o'\n"
+ "can not be initialized by Scheme programs.")
+#define FUNC_NAME s_scm_make_struct
{
SCM layout;
int basic_size;
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);
+ SCM_VALIDATE_VTABLE (1,vtable);
+ SCM_VALIDATE_INUM (2,tail_array_size);
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;
- if (SCM_STRUCT_DATA (vtable)[scm_struct_i_flags] & SCM_STRUCTF_ENTITY)
+ if (SCM_UNPACK (SCM_STRUCT_DATA (vtable)[scm_struct_i_flags]) & SCM_STRUCTF_ENTITY)
{
data = scm_alloc_struct (basic_size + tail_elts,
- scm_struct_n_extra_words + 5,
+ 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_procedure] = SCM_BOOL_F;
data[scm_struct_i_setter] = SCM_BOOL_F;
}
else
SCM_ALLOW_INTS;
return handle;
}
-
-
-
-SCM_PROC (s_make_vtable_vtable, "make-vtable-vtable", 2, 0, 1, scm_make_vtable_vtable);
-
-SCM
-scm_make_vtable_vtable (extra_fields, tail_array_size, init)
- SCM extra_fields;
- SCM tail_array_size;
- SCM init;
+#undef FUNC_NAME
+
+
+
+SCM_DEFINE (scm_make_vtable_vtable, "make-vtable-vtable", 2, 0, 1,
+ (SCM extra_fields, SCM tail_array_size, SCM init),
+ "Return a new, self-describing vtable structure.\n\n"
+ "@var{new-fields} is a layout specification describing fields\n"
+ "of the resulting structure beginning at the position bound to\n"
+ "@code{vtable-offset-user}.\n\n"
+ "@var{tail-size} specifies the size of the tail-array (if any) of\n"
+ "this vtable.\n\n"
+ "@var{inits} initializes the fields of the vtable. Minimally, one\n"
+ "initializer must be provided: the layout specification for instances\n"
+ "of the type this vtable will describe. If a second initializer is\n"
+ "provided, it will be interpreted as a print call-back function.\n\n"
+ "@example\n"
+ ";;; loading ,a...\n"
+ "(define x\n"
+ " (make-vtable-vtable (make-struct-layout (quote pw))\n"
+ " 0\n"
+ " 'foo))\n\n"
+ "(struct? x)\n"
+ "@result{} #t\n"
+ "(struct-vtable? x)\n"
+ "@result{} #t\n"
+ "(eq? x (struct-vtable x))\n"
+ "@result{} #t\n"
+ "(struct-ref x vtable-offset-user)\n"
+ "@result{} foo\n"
+ "(struct-ref x 0)\n"
+ "@result{} pruosrpwpw\n\n\n"
+ "(define y\n"
+ " (make-struct x\n"
+ " 0\n"
+ " (make-struct-layout (quote pwpwpw))\n"
+ " 'bar))\n\n"
+ "(struct? y)\n"
+ "@result{} #t\n"
+ "(struct-vtable? y)\n"
+ "@result{} #t\n"
+ "(eq? x y)\n"
+ "@result{} ()\n"
+ "(eq? x (struct-vtable y))\n"
+ "@result{} #t\n"
+ "(struct-ref y 0)\n"
+ "@result{} pwpwpw\n"
+ "(struct-ref y vtable-offset-user)\n"
+ "@result{} bar\n\n\n"
+ "(define z (make-struct y 0 'a 'b 'c))\n\n"
+ "(struct? z)\n"
+ "@result{} #t\n"
+ "(struct-vtable? z)\n"
+ "@result{} ()\n"
+ "(eq? y (struct-vtable z))\n"
+ "@result{} #t\n"
+ "(map (lambda (n) (struct-ref z n)) '(0 1 2))\n"
+ "@result{} (a b c)\n"
+ "@end example\n"
+ "")
+#define FUNC_NAME s_scm_make_vtable_vtable
{
SCM fields;
SCM layout;
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_ARG2,
- s_make_vtable_vtable);
+ SCM_VALIDATE_ROSTRING (1,extra_fields);
+ SCM_VALIDATE_INUM (2,tail_array_size);
fields = scm_string_append (scm_listify (required_vtable_fields,
extra_fields,
SCM_ALLOW_INTS;
return handle;
}
+#undef FUNC_NAME
\f
-SCM_PROC (s_struct_ref, "struct-ref", 2, 0, 0, scm_struct_ref);
-
-SCM
-scm_struct_ref (handle, pos)
- SCM handle;
- SCM pos;
+SCM_DEFINE (scm_struct_ref, "struct-ref", 2, 0, 0,
+ (SCM handle, SCM pos),
+ "@deffnx primitive 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"
+ "integer value small enough to fit in one machine word.")
+#define FUNC_NAME s_scm_struct_ref
{
SCM answer = SCM_UNDEFINED;
SCM * data;
SCM layout;
int p;
- int n_fields;
+ scm_bits_t n_fields;
unsigned char * fields_desc;
unsigned char field_type = 0;
- 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);
+ SCM_VALIDATE_STRUCT (1,handle);
+ SCM_VALIDATE_INUM (2,pos);
layout = SCM_STRUCT_LAYOUT (handle);
data = SCM_STRUCT_DATA (handle);
p = SCM_INUM (pos);
- fields_desc = (unsigned char *)SCM_CHARS (layout);
- n_fields = data[scm_struct_i_n_words] - scm_struct_n_extra_words;
+ fields_desc = (unsigned char *) SCM_CHARS (layout);
+ n_fields = SCM_UNPACK (data[scm_struct_i_n_words]);
- SCM_ASSERT (p < n_fields, pos, SCM_OUTOFRANGE, s_struct_ref);
+ SCM_ASSERT_RANGE(1,pos, p < n_fields);
if (p * 2 < SCM_LENGTH (layout))
{
if ((ref == 'R') || (ref == 'W'))
field_type = 'u';
else
- SCM_ASSERT (0, pos, "ref denied", s_struct_ref);
+ SCM_ASSERT (0, pos, "ref denied", FUNC_NAME);
}
}
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);
+ SCM_ASSERT (0, pos, "ref denied", FUNC_NAME);
abort ();
}
switch (field_type)
{
case 'u':
- answer = scm_ulong2num (data[p]);
+ answer = scm_ulong2num (SCM_UNPACK (data[p]));
break;
#if 0
default:
- SCM_ASSERT (0, SCM_MAKICHR (field_type), "unrecognized field type", s_struct_ref);
+ SCM_ASSERT (0, SCM_MAKE_CHAR (field_type), "unrecognized field type", FUNC_NAME);
break;
}
return answer;
}
+#undef FUNC_NAME
-SCM_PROC (s_struct_set_x, "struct-set!", 3, 0, 0, scm_struct_set_x);
-
-SCM
-scm_struct_set_x (handle, pos, val)
- SCM handle;
- SCM pos;
- SCM val;
+SCM_DEFINE (scm_struct_set_x, "struct-set!", 3, 0, 0,
+ (SCM handle, SCM pos, SCM val),
+ "")
+#define FUNC_NAME s_scm_struct_set_x
{
SCM * data;
SCM layout;
int n_fields;
unsigned char * fields_desc;
unsigned char field_type = 0;
-
-
- 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);
+ SCM_VALIDATE_STRUCT (1,handle);
+ SCM_VALIDATE_INUM (2,pos);
layout = SCM_STRUCT_LAYOUT (handle);
data = SCM_STRUCT_DATA (handle);
p = SCM_INUM (pos);
fields_desc = (unsigned char *)SCM_CHARS (layout);
- n_fields = data[scm_struct_i_n_words] - scm_struct_n_extra_words;
+ n_fields = SCM_UNPACK (data[scm_struct_i_n_words]);
- SCM_ASSERT (p < n_fields, pos, SCM_OUTOFRANGE, s_struct_set_x);
+ SCM_ASSERT_RANGE (1,pos, p < n_fields);
if (p * 2 < SCM_LENGTH (layout))
{
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);
+ SCM_ASSERT (0, pos, "set_x denied", FUNC_NAME);
}
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);
+ SCM_ASSERT (0, pos, "set_x denied", FUNC_NAME);
abort ();
}
switch (field_type)
{
case 'u':
- data[p] = (SCM)scm_num2ulong (val, (char *)SCM_ARG3, s_struct_set_x);
+ data[p] = SCM_PACK (SCM_NUM2ULONG (3, val));
break;
#if 0
case 'i':
- data[p] = scm_num2long (val, (char *)SCM_ARG3, s_struct_set_x);
+ data[p] = SCM_NUM2LONG (3,val);
break;
case 'd':
break;
case 's':
- SCM_ASSERT (0, SCM_MAKICHR (field_type), "self fields immutable", s_struct_set_x);
+ SCM_ASSERT (0, SCM_MAKE_CHAR (field_type), "self fields immutable", FUNC_NAME);
break;
default:
- SCM_ASSERT (0, SCM_MAKICHR (field_type), "unrecognized field type", s_struct_set_x);
+ SCM_ASSERT (0, SCM_MAKE_CHAR (field_type), "unrecognized field type", FUNC_NAME);
break;
}
return val;
}
+#undef FUNC_NAME
-SCM_PROC (s_struct_vtable, "struct-vtable", 1, 0, 0, scm_struct_vtable);
-
-SCM
-scm_struct_vtable (handle)
- SCM handle;
+SCM_DEFINE (scm_struct_vtable, "struct-vtable", 1, 0, 0,
+ (SCM handle),
+ "Return the vtable structure that describes the type of @var{struct}.")
+#define FUNC_NAME s_scm_struct_vtable
{
- SCM_ASSERT (SCM_NIMP (handle) && SCM_STRUCTP (handle), handle,
- SCM_ARG1, s_struct_vtable);
+ SCM_VALIDATE_STRUCT (1,handle);
return SCM_STRUCT_VTABLE (handle);
}
+#undef FUNC_NAME
-SCM_PROC (s_struct_vtable_tag, "struct-vtable-tag", 1, 0, 0, scm_struct_vtable_tag);
+SCM_DEFINE (scm_struct_vtable_tag, "struct-vtable-tag", 1, 0, 0,
+ (SCM handle),
+ "")
+#define FUNC_NAME s_scm_struct_vtable_tag
+{
+ SCM_VALIDATE_VTABLE (1,handle);
+ return scm_long2num ((long) 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
+ * 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)
+{
+ /* The length of the hash table should be a relative prime it's not
+ necessary to shift down the address. */
+ return SCM_UNPACK (obj) % n;
+}
SCM
-scm_struct_vtable_tag (handle)
- SCM handle;
+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_DEFINE (scm_struct_vtable_name, "struct-vtable-name", 1, 0, 0,
+ (SCM vtable),
+ "")
+#define FUNC_NAME s_scm_struct_vtable_name
+{
+ SCM_VALIDATE_VTABLE (1,vtable);
+ return SCM_STRUCT_TABLE_NAME (SCM_CDR (scm_struct_create_handle (vtable)));
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_set_struct_vtable_name_x, "set-struct-vtable-name!", 2, 0, 0,
+ (SCM vtable, SCM name),
+ "")
+#define FUNC_NAME s_scm_set_struct_vtable_name_x
{
- 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]);
+ 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;
}
+#undef FUNC_NAME
\f
void
-scm_print_struct (exp, port, pstate)
- SCM exp;
- SCM port;
- scm_print_state *pstate;
+scm_print_struct (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 vtable = SCM_STRUCT_VTABLE (exp);
+ SCM name = scm_struct_vtable_name (vtable);
+ scm_puts ("#<", port);
+ if (SCM_NFALSEP (name))
+ scm_display (name, port);
+ else
+ scm_puts ("struct", port);
+ scm_putc (' ', port);
+ scm_intprint ((int) vtable, 16, port);
scm_putc (':', port);
- scm_intprint (exp, 16, port);
+ scm_intprint ((int)exp, 16, port);
scm_putc ('>', port);
}
}
void
scm_init_struct ()
{
+ 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 ("vtable-index-layout", SCM_MAKINUM (scm_vtable_index_layout));
scm_sysintern ("vtable-offset-user", SCM_MAKINUM (scm_vtable_offset_user));
#include "struct.x"
}
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
HCoop / bpt / guile.git / blobdiff