libguile/struct.c

   1 /* Copyright (C) 1996, 97, 98, 99, 2000 Free Software Foundation, Inc.
   2  *
   3  * This program is free software; you can redistribute it and/or modify
   4  * it under the terms of the GNU General Public License as published by
   5  * the Free Software Foundation; either version 2, or (at your option)
   6  * any later version.
   7  *
   8  * This program is distributed in the hope that it will be useful,
   9  * but WITHOUT ANY WARRANTY; without even the implied warranty of
  10  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  11  * GNU General Public License for more details.
  12  *
  13  * You should have received a copy of the GNU General Public License
  14  * along with this software; see the file COPYING.  If not, write to
  15  * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
  16  * Boston, MA 02111-1307 USA
  17  *
  18  * As a special exception, the Free Software Foundation gives permission
  19  * for additional uses of the text contained in its release of GUILE.
  20  *
  21  * The exception is that, if you link the GUILE library with other files
  22  * to produce an executable, this does not by itself cause the
  23  * resulting executable to be covered by the GNU General Public License.
  24  * Your use of that executable is in no way restricted on account of
  25  * linking the GUILE library code into it.
  26  *
  27  * This exception does not however invalidate any other reasons why
  28  * the executable file might be covered by the GNU General Public License.
  29  *
  30  * This exception applies only to the code released by the
  31  * Free Software Foundation under the name GUILE.  If you copy
  32  * code from other Free Software Foundation releases into a copy of
  33  * GUILE, as the General Public License permits, the exception does
  34  * not apply to the code that you add in this way.  To avoid misleading
  35  * anyone as to the status of such modified files, you must delete
  36  * this exception notice from them.
  37  *
  38  * If you write modifications of your own for GUILE, it is your choice
  39  * whether to permit this exception to apply to your modifications.
  40  * If you do not wish that, delete this exception notice.  */
  41
  42 /* Software engineering face-lift by Greg J. Badros, 11-Dec-1999,
  43    gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */
  44
  45 \f
  46
  47 #include <stdio.h>
  48 #include "libguile/_scm.h"
  49 #include "libguile/chars.h"
  50 #include "libguile/eval.h"
  51 #include "libguile/alist.h"
  52 #include "libguile/weaks.h"
  53 #include "libguile/hashtab.h"
  54 #include "libguile/ports.h"
  55 #include "libguile/strings.h"
  56
  57 #include "libguile/validate.h"
  58 #include "libguile/struct.h"
  59
  60 #ifdef HAVE_STRING_H
  61 #include <string.h>
  62 #endif
  63
  64 \f
  65
  66 static SCM required_vtable_fields = SCM_BOOL_F;
  67 SCM scm_struct_table;
  68
  69 \f
  70 SCM_DEFINE (scm_make_struct_layout, "make-struct-layout", 1, 0, 0,
  71             (SCM fields),
  72             "Return a new structure layout object.\n\n"
  73             "@var{fields} must be a read-only string made up of pairs of characters\n"
  74             "strung together.  The first character of each pair describes a field\n"
  75             "type, the second a field protection.  Allowed types are 'p' for\n"
  76             "GC-protected Scheme data, 'u' for unprotected binary data, and 's' for\n"
  77             "fields that should point to the structure itself.    Allowed protections\n"
  78             "are 'w' for mutable fields, 'r' for read-only fields, and 'o' for opaque \n"
  79             "fields.  The last field protection specification may be capitalized to\n"
  80             "indicate that the field is a tail-array.")
  81 #define FUNC_NAME s_scm_make_struct_layout
  82 {
  83   SCM new_sym;
  84   SCM_VALIDATE_ROSTRING (1,fields);
  85   { /* scope */
  86     char * field_desc;
  87     int len;
  88     int x;
  89
  90     len = SCM_ROLENGTH (fields);
  91     field_desc = SCM_ROCHARS (fields);
  92     SCM_ASSERT (!(len & 1), fields, "odd length field specification", FUNC_NAME);
  93
  94     for (x = 0; x < len; x += 2)
  95       {
  96         switch (field_desc[x])
  97           {
  98           case 'u':
  99           case 'p':
 100 #if 0
 101           case 'i':
 102           case 'd':
 103 #endif
 104           case 's':
 105             break;
 106           default:
 107             SCM_ASSERT (0, SCM_MAKE_CHAR (field_desc[x]) , "unrecognized field type", FUNC_NAME);
 108           }
 109
 110         switch (field_desc[x + 1])
 111           {
 112           case 'w':
 113             SCM_ASSERT (field_desc[x] != 's', SCM_MAKE_CHAR (field_desc[x + 1]),
 114                         "self fields not writable", FUNC_NAME);
 115
 116           case 'r':
 117           case 'o':
 118             break;
 119           case 'R':
 120           case 'W':
 121           case 'O':
 122             SCM_ASSERT (field_desc[x] != 's', SCM_MAKE_CHAR (field_desc[x + 1]),
 123                         "self fields not allowed in tail array",
 124                         FUNC_NAME);
 125             SCM_ASSERT (x == len - 2, SCM_MAKE_CHAR (field_desc[x + 1]),
 126                         "tail array field must be last field in layout",
 127                         FUNC_NAME);
 128             break;
 129           default:
 130             SCM_ASSERT (0, SCM_MAKE_CHAR (field_desc[x]) , "unrecognized ref specification", FUNC_NAME);
 131           }
 132 #if 0
 133         if (field_desc[x] == 'd')
 134           {
 135             SCM_ASSERT (field_desc[x + 2] == '-', SCM_MAKINUM (x / 2), "missing dash field", FUNC_NAME);
 136             x += 2;
 137             goto recheck_ref;
 138           }
 139 #endif
 140       }
 141     new_sym = SCM_CAR (scm_intern_obarray (field_desc, len, SCM_BOOL_F));
 142   }
 143   return scm_return_first (new_sym, fields);
 144 }
 145 #undef FUNC_NAME
 146
 147 \f
 148
 149
 150
 151 void
 152 scm_struct_init (SCM handle, int tail_elts, SCM inits)
 153 {
 154   SCM layout = SCM_STRUCT_LAYOUT (handle);
 155   unsigned char * fields_desc = (unsigned char *) SCM_CHARS (layout) - 2;
 156   unsigned char prot = 0;
 157   int n_fields = SCM_LENGTH (layout) / 2;
 158   scm_bits_t * mem = SCM_STRUCT_DATA (handle);
 159   int tailp = 0;
 160
 161   while (n_fields)
 162     {
 163       if (!tailp)
 164         {
 165           fields_desc += 2;
 166           prot = fields_desc[1];
 167           if (SCM_LAYOUT_TAILP (prot))
 168             {
 169               tailp = 1;
 170               prot = prot == 'R' ? 'r' : prot == 'W' ? 'w' : 'o';
 171               *mem++ = tail_elts;
 172               n_fields += tail_elts - 1;
 173               if (n_fields == 0)
 174                 break;
 175             }
 176         }
 177
 178       switch (*fields_desc)
 179         {
 180 #if 0
 181         case 'i':
 182           if ((prot != 'r' && prot != 'w') || inits == SCM_EOL)
 183             *mem = 0;
 184           else
 185             {
 186               *mem = scm_num2long (SCM_CAR (inits), SCM_ARGn, "scm_struct_init");
 187               inits = SCM_CDR (inits);
 188             }
 189           break;
 190 #endif
 191
 192         case 'u':
 193           if ((prot != 'r' && prot != 'w') || SCM_NULLP (inits))
 194             *mem = 0;
 195           else
 196             {
 197               *mem = scm_num2ulong (SCM_CAR (inits),
 198                                     SCM_ARGn,
 199                                     "scm_struct_init");
 200               inits = SCM_CDR (inits);
 201             }
 202           break;
 203
 204         case 'p':
 205           if ((prot != 'r' && prot != 'w') || SCM_NULLP (inits))
 206             *mem = SCM_UNPACK (SCM_BOOL_F);
 207           else
 208             {
 209               *mem = SCM_UNPACK (SCM_CAR (inits));
 210               inits = SCM_CDR (inits);
 211             }
 212
 213           break;
 214
 215 #if 0
 216         case 'd':
 217           if ((prot != 'r' && prot != 'w') || inits == SCM_EOL)
 218             *((double *)mem) = 0.0;
 219           else
 220             {
 221               *mem = scm_num2dbl (SCM_CAR (inits), "scm_struct_init");
 222               inits = SCM_CDR (inits);
 223             }
 224           fields_desc += 2;
 225           break;
 226 #endif
 227
 228         case 's':
 229           *mem = SCM_UNPACK (handle);
 230           break;
 231         }
 232
 233       n_fields--;
 234       mem++;
 235     }
 236 }
 237
 238
 239 SCM_DEFINE (scm_struct_p, "struct?", 1, 0, 0,
 240             (SCM x),
 241             "Return #t iff @var{obj} is a structure object, else #f.")
 242 #define FUNC_NAME s_scm_struct_p
 243 {
 244   return SCM_BOOL(SCM_STRUCTP (x));
 245 }
 246 #undef FUNC_NAME
 247
 248 SCM_DEFINE (scm_struct_vtable_p, "struct-vtable?", 1, 0, 0,
 249             (SCM x),
 250             "Return #t iff obj is a vtable structure.")
 251 #define FUNC_NAME s_scm_struct_vtable_p
 252 {
 253   SCM layout;
 254   scm_bits_t * mem;
 255
 256   if (!SCM_STRUCTP (x))
 257     return SCM_BOOL_F;
 258
 259   layout = SCM_STRUCT_LAYOUT (x);
 260
 261   if (SCM_LENGTH (layout) < SCM_LENGTH (required_vtable_fields))
 262     return SCM_BOOL_F;
 263
 264   if (strncmp (SCM_CHARS (layout), SCM_CHARS (required_vtable_fields),
 265                SCM_LENGTH (required_vtable_fields)))
 266     return SCM_BOOL_F;
 267
 268   mem = SCM_STRUCT_DATA (x);
 269
 270   if (mem[1] != 0)
 271     return SCM_BOOL_F;
 272
 273   return SCM_BOOL (SCM_SYMBOLP (SCM_PACK (mem[0])));
 274 }
 275 #undef FUNC_NAME
 276
 277
 278 /* All struct data must be allocated at an address whose bottom three
 279    bits are zero.  This is because the tag for a struct lives in the
 280    bottom three bits of the struct's car, and the upper bits point to
 281    the data of its vtable, which is a struct itself.  Thus, if the
 282    address of that data doesn't end in three zeros, tagging it will
 283    destroy the pointer.
 284
 285    This function allocates a block of memory, and returns a pointer at
 286    least scm_struct_n_extra_words words into the block.  Furthermore,
 287    it guarantees that that pointer's least three significant bits are
 288    all zero.
 289
 290    The argument n_words should be the number of words that should
 291    appear after the returned address.  (That is, it shouldn't include
 292    scm_struct_n_extra_words.)
 293
 294    This function initializes the following fields of the struct:
 295
 296      scm_struct_i_ptr --- the actual start of the block of memory; the
 297          address you should pass to 'free' to dispose of the block.
 298          This field allows us to both guarantee that the returned
 299          address is divisible by eight, and allow the GC to free the
 300          block.
 301
 302      scm_struct_i_n_words --- the number of words allocated to the
 303          block, including the extra fields.  This is used by the GC.
 304
 305      Ugh.  */
 306
 307
 308 scm_bits_t *
 309 scm_alloc_struct (int n_words, int n_extra, char *who)
 310 {
 311   int size = sizeof (scm_bits_t) * (n_words + n_extra) + 7;
 312   void * block = scm_must_malloc (size, who);
 313
 314   /* Adjust the pointer to hide the extra words.  */
 315   scm_bits_t * p = (scm_bits_t *) block + n_extra;
 316
 317   /* Adjust it even further so it's aligned on an eight-byte boundary.  */
 318   p = (scm_bits_t *) (((scm_bits_t) p + 7) & ~7);
 319
 320   /* Initialize a few fields as described above.  */
 321   p[scm_struct_i_free] = (scm_bits_t) scm_struct_free_standard;
 322   p[scm_struct_i_ptr] = (scm_bits_t) block;
 323   p[scm_struct_i_n_words] = n_words;
 324   p[scm_struct_i_flags] = 0;
 325
 326   return p;
 327 }
 328
 329 scm_sizet
 330 scm_struct_free_0 (scm_bits_t * vtable, scm_bits_t * data)
 331 {
 332   return 0;
 333 }
 334
 335 scm_sizet
 336 scm_struct_free_light (scm_bits_t * vtable, scm_bits_t * data)
 337 {
 338   scm_must_free (data);
 339   return vtable [scm_struct_i_size] & ~SCM_STRUCTF_MASK;
 340 }
 341
 342 scm_sizet
 343 scm_struct_free_standard (scm_bits_t * vtable, scm_bits_t * data)
 344 {
 345   size_t n = (data[scm_struct_i_n_words] + scm_struct_n_extra_words)
 346              * sizeof (scm_bits_t) + 7;
 347   scm_must_free ((void *) data[scm_struct_i_ptr]);
 348   return n;
 349 }
 350
 351 scm_sizet
 352 scm_struct_free_entity (scm_bits_t * vtable, scm_bits_t * data)
 353 {
 354   size_t n = (data[scm_struct_i_n_words] + scm_struct_entity_n_extra_words)
 355              * sizeof (scm_bits_t) + 7;
 356   scm_must_free ((void *) data[scm_struct_i_ptr]);
 357   return n;
 358 }
 359
 360 SCM_DEFINE (scm_make_struct, "make-struct", 2, 0, 1,
 361             (SCM vtable, SCM tail_array_size, SCM init),
 362             "Create a new structure.\n\n"
 363             "@var{type} must be a vtable structure (@xref{Vtables}).\n\n"
 364             "@var{tail-elts} must be a non-negative integer.  If the layout\n"
 365             "specification indicated by @var{type} includes a tail-array,\n"
 366             "this is the number of elements allocated to that array.\n\n"
 367             "The @var{inits} are optional arguments describing how successive fields\n"
 368             "of the structure should be initialized.  Only fields with protection 'r'\n"
 369             "or 'w' can be initialized -- fields of protection 's' are automatically\n"
 370             "initialized to point to the new structure itself;  fields of protection 'o'\n"
 371             "can not be initialized by Scheme programs.")
 372 #define FUNC_NAME s_scm_make_struct
 373 {
 374   SCM layout;
 375   int basic_size;
 376   int tail_elts;
 377   scm_bits_t * data;
 378   SCM handle;
 379
 380   SCM_VALIDATE_VTABLE (1,vtable);
 381   SCM_VALIDATE_INUM (2,tail_array_size);
 382
 383   layout = SCM_PACK (SCM_STRUCT_DATA (vtable) [scm_vtable_index_layout]);
 384   basic_size = SCM_LENGTH (layout) / 2;
 385   tail_elts = SCM_INUM (tail_array_size);
 386   SCM_NEWCELL (handle);
 387   SCM_DEFER_INTS;
 388   if (SCM_STRUCT_DATA (vtable)[scm_struct_i_flags] & SCM_STRUCTF_ENTITY)
 389     {
 390       data = scm_alloc_struct (basic_size + tail_elts,
 391                                scm_struct_entity_n_extra_words,
 392                                "make-struct");
 393       data[scm_struct_i_procedure] = SCM_UNPACK (SCM_BOOL_F);
 394       data[scm_struct_i_setter] = SCM_UNPACK (SCM_BOOL_F);
 395     }
 396   else
 397     data = scm_alloc_struct (basic_size + tail_elts,
 398                              scm_struct_n_extra_words,
 399                              "make-struct");
 400   SCM_SET_CELL_WORD_1 (handle, data);
 401   SCM_SET_CELL_WORD_0 (handle, (scm_bits_t) SCM_STRUCT_DATA (vtable) + scm_tc3_cons_gloc);
 402   scm_struct_init (handle, tail_elts, init);
 403   SCM_ALLOW_INTS;
 404   return handle;
 405 }
 406 #undef FUNC_NAME
 407
 408
 409
 410 SCM_DEFINE (scm_make_vtable_vtable, "make-vtable-vtable", 2, 0, 1,
 411             (SCM extra_fields, SCM tail_array_size, SCM init),
 412             "Return a new, self-describing vtable structure.\n\n"
 413             "@var{new-fields} is a layout specification describing fields\n"
 414             "of the resulting structure beginning at the position bound to\n"
 415             "@code{vtable-offset-user}.\n\n"
 416             "@var{tail-size} specifies the size of the tail-array (if any) of\n"
 417             "this vtable.\n\n"
 418             "@var{inits} initializes the fields of the vtable.  Minimally, one\n"
 419             "initializer must be provided: the layout specification for instances\n"
 420             "of the type this vtable will describe.  If a second initializer is\n"
 421             "provided, it will be interpreted as a print call-back function.\n\n"
 422             "@example\n"
 423             ";;; loading ,a...\n"
 424             "(define x\n"
 425             "  (make-vtable-vtable (make-struct-layout (quote pw))\n"
 426             "                      0\n"
 427             "                      'foo))\n\n"
 428             "(struct? x)\n"
 429             "@result{} #t\n"
 430             "(struct-vtable? x)\n"
 431             "@result{} #t\n"
 432             "(eq? x (struct-vtable x))\n"
 433             "@result{} #t\n"
 434             "(struct-ref x vtable-offset-user)\n"
 435             "@result{} foo\n"
 436             "(struct-ref x 0)\n"
 437             "@result{} pruosrpwpw\n\n\n"
 438             "(define y\n"
 439             "  (make-struct x\n"
 440             "               0\n"
 441             "               (make-struct-layout (quote pwpwpw))\n"
 442             "               'bar))\n\n"
 443             "(struct? y)\n"
 444             "@result{} #t\n"
 445             "(struct-vtable? y)\n"
 446             "@result{} #t\n"
 447             "(eq? x y)\n"
 448             "@result{} ()\n"
 449             "(eq? x (struct-vtable y))\n"
 450             "@result{} #t\n"
 451             "(struct-ref y 0)\n"
 452             "@result{} pwpwpw\n"
 453             "(struct-ref y vtable-offset-user)\n"
 454             "@result{} bar\n\n\n"
 455             "(define z (make-struct y 0 'a 'b 'c))\n\n"
 456             "(struct? z)\n"
 457             "@result{} #t\n"
 458             "(struct-vtable? z)\n"
 459             "@result{} ()\n"
 460             "(eq? y (struct-vtable z))\n"
 461             "@result{} #t\n"
 462             "(map (lambda (n) (struct-ref z n)) '(0 1 2))\n"
 463             "@result{} (a b c)\n"
 464             "@end example\n"
 465             "")
 466 #define FUNC_NAME s_scm_make_vtable_vtable
 467 {
 468   SCM fields;
 469   SCM layout;
 470   int basic_size;
 471   int tail_elts;
 472   scm_bits_t * data;
 473   SCM handle;
 474
 475   SCM_VALIDATE_ROSTRING (1,extra_fields);
 476   SCM_VALIDATE_INUM (2,tail_array_size);
 477
 478   fields = scm_string_append (scm_listify (required_vtable_fields,
 479                                            extra_fields,
 480                                            SCM_UNDEFINED));
 481   layout = scm_make_struct_layout (fields);
 482   basic_size = SCM_LENGTH (layout) / 2;
 483   tail_elts = SCM_INUM (tail_array_size);
 484   SCM_NEWCELL (handle);
 485   SCM_DEFER_INTS;
 486   data = scm_alloc_struct (basic_size + tail_elts,
 487                            scm_struct_n_extra_words,
 488                            "make-vtable-vtable");
 489   SCM_SET_CELL_WORD_1 (handle, data);
 490   SCM_SET_CELL_WORD_0 (handle, (scm_bits_t) data + scm_tc3_cons_gloc);
 491   SCM_SET_STRUCT_LAYOUT (handle, layout);
 492   scm_struct_init (handle, tail_elts, scm_cons (layout, init));
 493   SCM_ALLOW_INTS;
 494   return handle;
 495 }
 496 #undef FUNC_NAME
 497
 498 \f
 499
 500
 501 SCM_DEFINE (scm_struct_ref, "struct-ref", 2, 0, 0,
 502             (SCM handle, SCM pos),
 503             "@deffnx primitive struct-set! struct n value\n"
 504             "Access (or modify) the @var{n}th field of @var{struct}.\n\n"
 505             "If the field is of type 'p', then it can be set to an arbitrary value.\n\n"
 506             "If the field is of type 'u', then it can only be set to a non-negative\n"
 507             "integer value small enough to fit in one machine word.")
 508 #define FUNC_NAME s_scm_struct_ref
 509 {
 510   SCM answer = SCM_UNDEFINED;
 511   scm_bits_t * data;
 512   SCM layout;
 513   int p;
 514   scm_bits_t n_fields;
 515   unsigned char * fields_desc;
 516   unsigned char field_type = 0;
 517
 518
 519   SCM_VALIDATE_STRUCT (1,handle);
 520   SCM_VALIDATE_INUM (2,pos);
 521
 522   layout = SCM_STRUCT_LAYOUT (handle);
 523   data = SCM_STRUCT_DATA (handle);
 524   p = SCM_INUM (pos);
 525
 526   fields_desc = (unsigned char *) SCM_CHARS (layout);
 527   n_fields = data[scm_struct_i_n_words];
 528
 529   SCM_ASSERT_RANGE(1,pos, p < n_fields);
 530
 531   if (p * 2 < SCM_LENGTH (layout))
 532     {
 533       unsigned char ref;
 534       field_type = fields_desc[p * 2];
 535       ref = fields_desc[p * 2 + 1];
 536       if ((ref != 'r') && (ref != 'w'))
 537         {
 538           if ((ref == 'R') || (ref == 'W'))
 539             field_type = 'u';
 540           else
 541             SCM_ASSERT (0, pos, "ref denied", FUNC_NAME);
 542         }
 543     }
 544   else if (fields_desc[SCM_LENGTH (layout) - 1] != 'O')
 545     field_type = fields_desc[SCM_LENGTH (layout) - 2];
 546   else
 547     {
 548       SCM_ASSERT (0, pos, "ref denied", FUNC_NAME);
 549       abort ();
 550     }
 551
 552   switch (field_type)
 553     {
 554     case 'u':
 555       answer = scm_ulong2num (data[p]);
 556       break;
 557
 558 #if 0
 559     case 'i':
 560       answer = scm_long2num (data[p]);
 561       break;
 562
 563     case 'd':
 564       answer = scm_makdbl (*((double *)&(data[p])), 0.0);
 565       break;
 566 #endif
 567
 568     case 's':
 569     case 'p':
 570       answer = SCM_PACK (data[p]);
 571       break;
 572
 573
 574     default:
 575       SCM_ASSERT (0, SCM_MAKE_CHAR (field_type), "unrecognized field type", FUNC_NAME);
 576       break;
 577     }
 578
 579   return answer;
 580 }
 581 #undef FUNC_NAME
 582
 583
 584 SCM_DEFINE (scm_struct_set_x, "struct-set!", 3, 0, 0,
 585             (SCM handle, SCM pos, SCM val),
 586             "")
 587 #define FUNC_NAME s_scm_struct_set_x
 588 {
 589   scm_bits_t * data;
 590   SCM layout;
 591   int p;
 592   int n_fields;
 593   unsigned char * fields_desc;
 594   unsigned char field_type = 0;
 595
 596   SCM_VALIDATE_STRUCT (1,handle);
 597   SCM_VALIDATE_INUM (2,pos);
 598
 599   layout = SCM_STRUCT_LAYOUT (handle);
 600   data = SCM_STRUCT_DATA (handle);
 601   p = SCM_INUM (pos);
 602
 603   fields_desc = (unsigned char *)SCM_CHARS (layout);
 604   n_fields = data[scm_struct_i_n_words];
 605
 606   SCM_ASSERT_RANGE (1,pos, p < n_fields);
 607
 608   if (p * 2 < SCM_LENGTH (layout))
 609     {
 610       unsigned char set_x;
 611       field_type = fields_desc[p * 2];
 612       set_x = fields_desc [p * 2 + 1];
 613       if (set_x != 'w')
 614         SCM_ASSERT (0, pos, "set_x denied", FUNC_NAME);
 615     }
 616   else if (fields_desc[SCM_LENGTH (layout) - 1] == 'W')
 617     field_type = fields_desc[SCM_LENGTH (layout) - 2];
 618   else
 619     {
 620       SCM_ASSERT (0, pos, "set_x denied", FUNC_NAME);
 621       abort ();
 622     }
 623
 624   switch (field_type)
 625     {
 626     case 'u':
 627       data[p] = SCM_NUM2ULONG (3, val);
 628       break;
 629
 630 #if 0
 631     case 'i':
 632       data[p] = SCM_NUM2LONG (3,val);
 633       break;
 634
 635     case 'd':
 636       *((double *)&(data[p])) = scm_num2dbl (val, (char *)SCM_ARG3);
 637       break;
 638 #endif
 639
 640     case 'p':
 641       data[p] = SCM_UNPACK (val);
 642       break;
 643
 644     case 's':
 645       SCM_ASSERT (0, SCM_MAKE_CHAR (field_type), "self fields immutable", FUNC_NAME);
 646       break;
 647
 648     default:
 649       SCM_ASSERT (0, SCM_MAKE_CHAR (field_type), "unrecognized field type", FUNC_NAME);
 650       break;
 651     }
 652
 653   return val;
 654 }
 655 #undef FUNC_NAME
 656
 657
 658 SCM_DEFINE (scm_struct_vtable, "struct-vtable", 1, 0, 0,
 659             (SCM handle),
 660             "Return the vtable structure that describes the type of @var{struct}.")
 661 #define FUNC_NAME s_scm_struct_vtable
 662 {
 663   SCM_VALIDATE_STRUCT (1,handle);
 664   return SCM_STRUCT_VTABLE (handle);
 665 }
 666 #undef FUNC_NAME
 667
 668
 669 SCM_DEFINE (scm_struct_vtable_tag, "struct-vtable-tag", 1, 0, 0,
 670             (SCM handle),
 671             "")
 672 #define FUNC_NAME s_scm_struct_vtable_tag
 673 {
 674   SCM_VALIDATE_VTABLE (1,handle);
 675   return scm_long2num ((long) SCM_STRUCT_DATA (handle) >> 3);
 676 }
 677 #undef FUNC_NAME
 678
 679 /* {Associating names and classes with vtables}
 680  *
 681  * The name of a vtable should probably be stored as a slot.  This is
 682  * a backward compatible solution until agreement has been achieved on
 683  * how to associate names with vtables.
 684  */
 685
 686 unsigned int
 687 scm_struct_ihashq (SCM obj, unsigned int n)
 688 {
 689   /* The length of the hash table should be a relative prime it's not
 690      necessary to shift down the address.  */
 691   return SCM_UNPACK (obj) % n;
 692 }
 693
 694 SCM
 695 scm_struct_create_handle (SCM obj)
 696 {
 697   SCM handle = scm_hash_fn_create_handle_x (scm_struct_table,
 698                                             obj,
 699                                             SCM_BOOL_F,
 700                                             scm_struct_ihashq,
 701                                             scm_sloppy_assq,
 702                                             0);
 703   if (SCM_FALSEP (SCM_CDR (handle)))
 704     SCM_SETCDR (handle, scm_cons (SCM_BOOL_F, SCM_BOOL_F));
 705   return handle;
 706 }
 707
 708 SCM_DEFINE (scm_struct_vtable_name, "struct-vtable-name", 1, 0, 0,
 709             (SCM vtable),
 710             "")
 711 #define FUNC_NAME s_scm_struct_vtable_name
 712 {
 713   SCM_VALIDATE_VTABLE (1,vtable);
 714   return SCM_STRUCT_TABLE_NAME (SCM_CDR (scm_struct_create_handle (vtable)));
 715 }
 716 #undef FUNC_NAME
 717
 718 SCM_DEFINE (scm_set_struct_vtable_name_x, "set-struct-vtable-name!", 2, 0, 0,
 719             (SCM vtable, SCM name),
 720             "")
 721 #define FUNC_NAME s_scm_set_struct_vtable_name_x
 722 {
 723   SCM_VALIDATE_VTABLE (1,vtable);
 724   SCM_VALIDATE_SYMBOL (2,name);
 725   SCM_SET_STRUCT_TABLE_NAME (SCM_CDR (scm_struct_create_handle (vtable)),
 726                              name);
 727   return SCM_UNSPECIFIED;
 728 }
 729 #undef FUNC_NAME
 730
 731
 732 \f
 733
 734 void
 735 scm_print_struct (SCM exp, SCM port, scm_print_state *pstate)
 736 {
 737   if (SCM_NFALSEP (scm_procedure_p (SCM_STRUCT_PRINTER (exp))))
 738     scm_printer_apply (SCM_STRUCT_PRINTER (exp), exp, port, pstate);
 739   else
 740     {
 741       SCM vtable = SCM_STRUCT_VTABLE (exp);
 742       SCM name = scm_struct_vtable_name (vtable);
 743       scm_puts ("#<", port);
 744       if (SCM_NFALSEP (name))
 745         scm_display (name, port);
 746       else
 747         scm_puts ("struct", port);
 748       scm_putc (' ', port);
 749       scm_intprint (SCM_UNPACK (vtable), 16, port);
 750       scm_putc (':', port);
 751       scm_intprint (SCM_UNPACK (exp), 16, port);
 752       scm_putc ('>', port);
 753     }
 754 }
 755
 756 void
 757 scm_init_struct ()
 758 {
 759   scm_struct_table
 760     = scm_permanent_object (scm_make_weak_key_hash_table (SCM_MAKINUM (31)));
 761   required_vtable_fields = SCM_CAR (scm_intern_obarray ("pruosrpw", sizeof ("pruosrpw") - 1, SCM_BOOL_F));
 762   scm_permanent_object (required_vtable_fields);
 763   scm_sysintern ("vtable-index-layout", SCM_MAKINUM (scm_vtable_index_layout));
 764   scm_sysintern ("vtable-index-vtable", SCM_MAKINUM (scm_vtable_index_vtable));
 765   scm_sysintern ("vtable-index-printer", SCM_MAKINUM (scm_vtable_index_printer));
 766   scm_sysintern ("vtable-offset-user", SCM_MAKINUM (scm_vtable_offset_user));
 767 #include "libguile/struct.x"
 768 }
 769
 770 /*
 771   Local Variables:
 772   c-file-style: "gnu"
 773   End:
 774 */