Fix: Don't cast SCM values to pointer. Use SCM2PTR instead.
[bpt/guile.git] / libguile / struct.c
index b913644..f6d8b9d 100644 (file)
@@ -1,4 +1,4 @@
-/*     Copyright (C) 1996, 1997, 1998, 1999 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
@@ -61,24 +67,29 @@ static SCM required_vtable_fields = SCM_BOOL_F;
 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)
       {
@@ -93,14 +104,14 @@ scm_make_struct_layout (fields)
          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':
@@ -108,20 +119,20 @@ scm_make_struct_layout (fields)
          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;
          }
@@ -131,16 +142,14 @@ scm_make_struct_layout (fields)
   }
   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;
@@ -165,7 +174,7 @@ scm_struct_init (handle, tail_elts, inits)
            {
              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;
@@ -191,7 +200,9 @@ scm_struct_init (handle, tail_elts, inits)
            *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;
@@ -231,22 +242,19 @@ scm_struct_init (handle, tail_elts, inits)
 }
 
 
-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;
@@ -274,10 +282,9 @@ scm_struct_vtable_p (x)
   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
@@ -320,7 +327,7 @@ scm_alloc_struct (int n_words, int n_extra, char *who)
   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;
@@ -341,13 +348,13 @@ scm_sizet
 scm_struct_free_light (SCM *vtable, SCM *data)
 {
   free (data);
-  return vtable[scm_struct_i_size] & ~SCM_STRUCTF_MASK;
+  return SCM_UNPACK (vtable[scm_struct_i_size]) & ~SCM_STRUCTF_MASK;
 }
 
 scm_sizet
 scm_struct_free_standard (SCM *vtable, SCM *data)
 {
-  size_t n = ((data[scm_struct_i_n_words] + scm_struct_n_extra_words)
+  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;
@@ -356,19 +363,25 @@ scm_struct_free_standard (SCM *vtable, SCM *data)
 scm_sizet
 scm_struct_free_entity (SCM *vtable, SCM *data)
 {
-  size_t n = ((data[scm_struct_i_n_words] + scm_struct_entity_n_extra_words)
+  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_PROC (s_make_struct, "make-struct", 2, 0, 1, scm_make_struct);
-
-SCM
-scm_make_struct (vtable, tail_array_size, init)
-     SCM vtable;
-     SCM tail_array_size;
-     SCM init;
+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;
@@ -376,17 +389,15 @@ scm_make_struct (vtable, tail_array_size, init)
   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_entity_n_extra_words,
@@ -404,16 +415,67 @@ scm_make_struct (vtable, tail_array_size, init)
   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;
@@ -422,10 +484,8 @@ scm_make_vtable_vtable (extra_fields, tail_array_size, init)
   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,
@@ -445,38 +505,40 @@ scm_make_vtable_vtable (extra_fields, tail_array_size, init)
   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];
+  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))
     {
@@ -488,21 +550,21 @@ scm_struct_ref (handle, pos)
          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
@@ -522,21 +584,19 @@ scm_struct_ref (handle, pos)
 
 
     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;
@@ -544,21 +604,18 @@ scm_struct_set_x (handle, pos, val)
   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];
+  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))
     {
@@ -566,25 +623,25 @@ scm_struct_set_x (handle, pos, val)
       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':
@@ -597,40 +654,39 @@ scm_struct_set_x (handle, pos, val)
       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
-scm_struct_vtable_tag (handle)
-     SCM handle;
+SCM_DEFINE (scm_struct_vtable_tag, "struct-vtable-tag", 1, 0, 0, 
+            (SCM handle),
+           "")
+#define FUNC_NAME s_scm_struct_vtable_tag
 {
-  SCM_ASSERT (SCM_NFALSEP (scm_struct_vtable_p (handle)),
-             handle, SCM_ARG1, s_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}
  *
@@ -644,7 +700,7 @@ 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 obj % n;
+  return SCM_UNPACK (obj) % n;
 }
 
 SCM
@@ -661,39 +717,34 @@ scm_struct_create_handle (SCM obj)
   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_DEFINE (scm_struct_vtable_name, "struct-vtable-name", 1, 0, 0, 
+            (SCM vtable),
+           "")
+#define FUNC_NAME s_scm_struct_vtable_name
 {
-  SCM_ASSERT (SCM_NFALSEP (scm_struct_vtable_p (vtable)),
-             vtable, SCM_ARG1, s_struct_vtable_name);
-  
+  SCM_VALIDATE_VTABLE (1,vtable);
   return SCM_STRUCT_TABLE_NAME (SCM_CDR (scm_struct_create_handle (vtable)));
 }
+#undef FUNC_NAME
 
-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_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 (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_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);
@@ -707,9 +758,9 @@ scm_print_struct (exp, port, pstate)
       else
        scm_puts ("struct", port);
       scm_putc (' ', port);
-      scm_intprint (vtable, 16, port);
+      scm_intprint ((int) vtable, 16, port);
       scm_putc (':', port);
-      scm_intprint (exp, 16, port);
+      scm_intprint ((int)exp, 16, port);
       scm_putc ('>', port);
     }
 }
@@ -727,3 +778,9 @@ scm_init_struct ()
   scm_sysintern ("vtable-offset-user", SCM_MAKINUM (scm_vtable_offset_user));
 #include "struct.x"
 }
+
+/*
+  Local Variables:
+  c-file-style: "gnu"
+  End:
+*/