libguile/struct.c

   1 /*      Copyright (C) 1996, 1997, 1998, 1999 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 "_scm.h"
  49 #include "chars.h"
  50 #include "genio.h"
  51 #include "eval.h"
  52 #include "alist.h"
  53 #include "weaks.h"
  54 #include "hashtab.h"
  55
  56 #include "scm_validate.h"
  57 #include "struct.h"
  58
  59 #ifdef HAVE_STRING_H
  60 #include <string.h>
  61 #endif
  62
  63 \f
  64
  65 static SCM required_vtable_fields = SCM_BOOL_F;
  66 SCM scm_struct_table;
  67
  68 \f
  69 GUILE_PROC (scm_make_struct_layout, "make-struct-layout", 1, 0, 0,
  70             (SCM fields),
  71 "Return a new structure layout object.
  72
  73 @var{fields} must be a read-only string made up of pairs of characters
  74 strung together.  The first character of each pair describes a field
  75 type, the second a field protection.  Allowed types are 'p' for
  76 GC-protected Scheme data, 'u' for unprotected binary data, and 's' for
  77 fields that should point to the structure itself.    Allowed protections
  78 are 'w' for mutable fields, 'r' for read-only fields, and 'o' for opaque
  79 fields.  The last field protection specification may be capitalized to
  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_MAKICHR (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_MAKICHR (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_MAKICHR (field_desc[x + 1]),
 123                         "self fields not allowed in tail array",
 124                         FUNC_NAME);
 125             SCM_ASSERT (x == len - 2, SCM_MAKICHR (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_MAKICHR (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;
 155   SCM * data;
 156   unsigned char * fields_desc;
 157   unsigned char prot = 0;
 158   int n_fields;
 159   SCM * mem;
 160   int tailp = 0;
 161
 162   layout = SCM_STRUCT_LAYOUT (handle);
 163   data = SCM_STRUCT_DATA (handle);
 164   fields_desc = (unsigned char *) SCM_CHARS (layout) - 2;
 165   n_fields = SCM_LENGTH (layout) / 2;
 166   mem = SCM_STRUCT_DATA (handle);
 167   while (n_fields)
 168     {
 169       if (!tailp)
 170         {
 171           fields_desc += 2;
 172           prot = fields_desc[1];
 173           if (SCM_LAYOUT_TAILP (prot))
 174             {
 175               tailp = 1;
 176               prot = prot == 'R' ? 'r' : prot == 'W' ? 'w' : 'o';
 177               *mem++ = tail_elts;
 178               n_fields += tail_elts - 1;
 179               if (n_fields == 0)
 180                 break;
 181             }
 182         }
 183
 184       switch (*fields_desc)
 185         {
 186 #if 0
 187         case 'i':
 188           if ((prot != 'r' && prot != 'w') || inits == SCM_EOL)
 189             *mem = 0;
 190           else
 191             {
 192               *mem = scm_num2long (SCM_CAR (inits), SCM_ARGn, "scm_struct_init");
 193               inits = SCM_CDR (inits);
 194             }
 195           break;
 196 #endif
 197
 198         case 'u':
 199           if ((prot != 'r' && prot != 'w') || inits == SCM_EOL)
 200             *mem = 0;
 201           else
 202             {
 203               *mem = scm_num2ulong (SCM_CAR (inits), SCM_ARGn, "scm_struct_init");
 204               inits = SCM_CDR (inits);
 205             }
 206           break;
 207
 208         case 'p':
 209           if ((prot != 'r' && prot != 'w') || inits == SCM_EOL)
 210             *mem = SCM_BOOL_F;
 211           else
 212             {
 213               *mem = SCM_CAR (inits);
 214               inits = SCM_CDR (inits);
 215             }
 216
 217           break;
 218
 219 #if 0
 220         case 'd':
 221           if ((prot != 'r' && prot != 'w') || inits == SCM_EOL)
 222             *((double *)mem) = 0.0;
 223           else
 224             {
 225               *mem = scm_num2dbl (SCM_CAR (inits), "scm_struct_init");
 226               inits = SCM_CDR (inits);
 227             }
 228           fields_desc += 2;
 229           break;
 230 #endif
 231
 232         case 's':
 233           *mem = handle;
 234           break;
 235         }
 236
 237       n_fields--;
 238       mem++;
 239     }
 240 }
 241
 242
 243 GUILE_PROC (scm_struct_p, "struct?", 1, 0, 0,
 244             (SCM x),
 245 "Return #t iff @var{obj} is a structure object, else #f.")
 246 #define FUNC_NAME s_scm_struct_p
 247 {
 248   return SCM_BOOL(SCM_STRUCTP (x));
 249 }
 250 #undef FUNC_NAME
 251
 252 GUILE_PROC (scm_struct_vtable_p, "struct-vtable?", 1, 0, 0,
 253             (SCM x),
 254 "Return #t iff obj is a vtable structure.")
 255 #define FUNC_NAME s_scm_struct_vtable_p
 256 {
 257   SCM layout;
 258   SCM * mem;
 259
 260   if (SCM_IMP (x))
 261     return SCM_BOOL_F;
 262
 263   if (!SCM_STRUCTP (x))
 264     return SCM_BOOL_F;
 265
 266   layout = SCM_STRUCT_LAYOUT (x);
 267
 268   if (SCM_LENGTH (layout) < SCM_LENGTH (required_vtable_fields))
 269     return SCM_BOOL_F;
 270
 271   if (strncmp (SCM_CHARS (layout), SCM_CHARS (required_vtable_fields),
 272                SCM_LENGTH (required_vtable_fields)))
 273     return SCM_BOOL_F;
 274
 275   mem = SCM_STRUCT_DATA (x);
 276
 277   if (mem[1] != 0)
 278     return SCM_BOOL_F;
 279
 280   if (SCM_IMP (mem[0]))
 281     return SCM_BOOL_F;
 282
 283   return SCM_BOOL(SCM_SYMBOLP (mem[0]));
 284 }
 285 #undef FUNC_NAME
 286
 287
 288 /* All struct data must be allocated at an address whose bottom three
 289    bits are zero.  This is because the tag for a struct lives in the
 290    bottom three bits of the struct's car, and the upper bits point to
 291    the data of its vtable, which is a struct itself.  Thus, if the
 292    address of that data doesn't end in three zeros, tagging it will
 293    destroy the pointer.
 294
 295    This function allocates a block of memory, and returns a pointer at
 296    least scm_struct_n_extra_words words into the block.  Furthermore,
 297    it guarantees that that pointer's least three significant bits are
 298    all zero.
 299
 300    The argument n_words should be the number of words that should
 301    appear after the returned address.  (That is, it shouldn't include
 302    scm_struct_n_extra_words.)
 303
 304    This function initializes the following fields of the struct:
 305
 306      scm_struct_i_ptr --- the actual start of the block of memory; the
 307          address you should pass to 'free' to dispose of the block.
 308          This field allows us to both guarantee that the returned
 309          address is divisible by eight, and allow the GC to free the
 310          block.
 311
 312      scm_struct_i_n_words --- the number of words allocated to the
 313          block, including the extra fields.  This is used by the GC.
 314
 315      Ugh.  */
 316
 317
 318 SCM *
 319 scm_alloc_struct (int n_words, int n_extra, char *who)
 320 {
 321   int size = sizeof (SCM) * (n_words + n_extra) + 7;
 322   SCM *block = (SCM *) scm_must_malloc (size, who);
 323
 324   /* Adjust the pointer to hide the extra words.  */
 325   SCM *p = block + n_extra;
 326
 327   /* Adjust it even further so it's aligned on an eight-byte boundary.  */
 328   p = (SCM *) (((SCM) p + 7) & ~7);
 329
 330   /* Initialize a few fields as described above.  */
 331   p[scm_struct_i_free] = (SCM) scm_struct_free_standard;
 332   p[scm_struct_i_ptr] = (SCM) block;
 333   p[scm_struct_i_n_words] = (SCM) n_words;
 334   p[scm_struct_i_flags] = 0;
 335
 336   return p;
 337 }
 338
 339 scm_sizet
 340 scm_struct_free_0 (SCM *vtable, SCM *data)
 341 {
 342   return 0;
 343 }
 344
 345 scm_sizet
 346 scm_struct_free_light (SCM *vtable, SCM *data)
 347 {
 348   free (data);
 349   return vtable[scm_struct_i_size] & ~SCM_STRUCTF_MASK;
 350 }
 351
 352 scm_sizet
 353 scm_struct_free_standard (SCM *vtable, SCM *data)
 354 {
 355   size_t n = ((data[scm_struct_i_n_words] + scm_struct_n_extra_words)
 356               * sizeof (SCM) + 7);
 357   free ((void *) data[scm_struct_i_ptr]);
 358   return n;
 359 }
 360
 361 scm_sizet
 362 scm_struct_free_entity (SCM *vtable, SCM *data)
 363 {
 364   size_t n = ((data[scm_struct_i_n_words] + scm_struct_entity_n_extra_words)
 365               * sizeof (SCM) + 7);
 366   free ((void *) data[scm_struct_i_ptr]);
 367   return n;
 368 }
 369
 370 GUILE_PROC (scm_make_struct, "make-struct", 2, 0, 1,
 371             (SCM vtable, SCM tail_array_size, SCM init),
 372 "Create a new structure.
 373
 374 @var{type} must be a vtable structure (@xref{Vtables}).
 375
 376 @var{tail-elts} must be a non-negative integer.  If the layout
 377 specification indicated by @var{type} includes a tail-array,
 378 this is the number of elements allocated to that array.
 379
 380 The @var{inits} are optional arguments describing how successive fields
 381 of the structure should be initialized.  Only fields with protection 'r'
 382 or 'w' can be initialized -- fields of protection 's' are automatically
 383 initialized to point to the new structure itself;  fields of protection 'o'
 384 can not be initialized by Scheme programs.")
 385 #define FUNC_NAME s_scm_make_struct
 386 {
 387   SCM layout;
 388   int basic_size;
 389   int tail_elts;
 390   SCM * data;
 391   SCM handle;
 392
 393   SCM_VALIDATE_VTABLE(1,vtable);
 394   SCM_VALIDATE_INT(2,tail_array_size);
 395
 396   layout = SCM_STRUCT_DATA (vtable)[scm_vtable_index_layout];
 397   basic_size = SCM_LENGTH (layout) / 2;
 398   tail_elts = SCM_INUM (tail_array_size);
 399   SCM_NEWCELL (handle);
 400   SCM_DEFER_INTS;
 401   if (SCM_STRUCT_DATA (vtable)[scm_struct_i_flags] & SCM_STRUCTF_ENTITY)
 402     {
 403       data = scm_alloc_struct (basic_size + tail_elts,
 404                                scm_struct_entity_n_extra_words,
 405                                "make-struct");
 406       data[scm_struct_i_procedure] = SCM_BOOL_F;
 407       data[scm_struct_i_setter] = SCM_BOOL_F;
 408     }
 409   else
 410     data = scm_alloc_struct (basic_size + tail_elts,
 411                              scm_struct_n_extra_words,
 412                              "make-struct");
 413   SCM_SETCDR (handle, data);
 414   SCM_SETCAR (handle, ((SCM)SCM_STRUCT_DATA (vtable)) + scm_tc3_cons_gloc);
 415   scm_struct_init (handle, tail_elts, init);
 416   SCM_ALLOW_INTS;
 417   return handle;
 418 }
 419 #undef FUNC_NAME
 420
 421
 422
 423 GUILE_PROC (scm_make_vtable_vtable, "make-vtable-vtable", 2, 0, 1,
 424             (SCM extra_fields, SCM tail_array_size, SCM init),
 425 "Return a new, self-describing vtable structure.
 426
 427 @var{new-fields} is a layout specification describing fields
 428 of the resulting structure beginning at the position bound to
 429 @code{vtable-offset-user}.
 430
 431 @var{tail-size} specifies the size of the tail-array (if any) of
 432 this vtable.
 433
 434 @var{inits} initializes the fields of the vtable.  Minimally, one
 435 initializer must be provided: the layout specification for instances
 436 of the type this vtable will describe.  If a second initializer is
 437 provided, it will be interpreted as a print call-back function.
 438
 439 @example
 440 ;;; loading ,a...
 441 (define x
 442   (make-vtable-vtable (make-struct-layout (quote pw))
 443                       0
 444                       'foo))
 445
 446 (struct? x)
 447 @result{} #t
 448 (struct-vtable? x)
 449 @result{} #t
 450 (eq? x (struct-vtable x))
 451 @result{} #t
 452 (struct-ref x vtable-offset-user)
 453 @result{} foo
 454 (struct-ref x 0)
 455 @result{} pruosrpwpw
 456
 457
 458 (define y
 459   (make-struct x
 460                0
 461                (make-struct-layout (quote pwpwpw))
 462                'bar))
 463
 464 (struct? y)
 465 @result{} #t
 466 (struct-vtable? y)
 467 @result{} #t
 468 (eq? x y)
 469 @result{} ()
 470 (eq? x (struct-vtable y))
 471 @result{} #t
 472 (struct-ref y 0)
 473 @result{} pwpwpw
 474 (struct-ref y vtable-offset-user)
 475 @result{} bar
 476
 477
 478 (define z (make-struct y 0 'a 'b 'c))
 479
 480 (struct? z)
 481 @result{} #t
 482 (struct-vtable? z)
 483 @result{} ()
 484 (eq? y (struct-vtable z))
 485 @result{} #t
 486 (map (lambda (n) (struct-ref z n)) '(0 1 2))
 487 @result{} (a b c)
 488 @end example
 489 ")
 490 #define FUNC_NAME s_scm_make_vtable_vtable
 491 {
 492   SCM fields;
 493   SCM layout;
 494   int basic_size;
 495   int tail_elts;
 496   SCM * data;
 497   SCM handle;
 498
 499   SCM_VALIDATE_ROSTRING(1,extra_fields);
 500   SCM_VALIDATE_INT(2,tail_array_size);
 501
 502   fields = scm_string_append (scm_listify (required_vtable_fields,
 503                                            extra_fields,
 504                                            SCM_UNDEFINED));
 505   layout = scm_make_struct_layout (fields);
 506   basic_size = SCM_LENGTH (layout) / 2;
 507   tail_elts = SCM_INUM (tail_array_size);
 508   SCM_NEWCELL (handle);
 509   SCM_DEFER_INTS;
 510   data = scm_alloc_struct (basic_size + tail_elts,
 511                            scm_struct_n_extra_words,
 512                            "make-vtable-vtable");
 513   SCM_SETCDR (handle, data);
 514   SCM_SETCAR (handle, ((SCM)data) + scm_tc3_cons_gloc);
 515   SCM_STRUCT_LAYOUT (handle) = layout;
 516   scm_struct_init (handle, tail_elts, scm_cons (layout, init));
 517   SCM_ALLOW_INTS;
 518   return handle;
 519 }
 520 #undef FUNC_NAME
 521
 522 \f
 523
 524
 525 GUILE_PROC (scm_struct_ref, "struct-ref", 2, 0, 0,
 526             (SCM handle, SCM pos),
 527 "@deffnx primitive struct-set! struct n value
 528 Access (or modify) the @var{n}th field of @var{struct}.
 529
 530 If the field is of type 'p', then it can be set to an arbitrary value.
 531
 532 If the field is of type 'u', then it can only be set to a non-negative
 533 integer value small enough to fit in one machine word.")
 534 #define FUNC_NAME s_scm_struct_ref
 535 {
 536   SCM answer = SCM_UNDEFINED;
 537   SCM * data;
 538   SCM layout;
 539   int p;
 540   int n_fields;
 541   unsigned char * fields_desc;
 542   unsigned char field_type = 0;
 543
 544
 545   SCM_VALIDATE_STRUCT(1,handle);
 546   SCM_VALIDATE_INT(2,pos);
 547
 548   layout = SCM_STRUCT_LAYOUT (handle);
 549   data = SCM_STRUCT_DATA (handle);
 550   p = SCM_INUM (pos);
 551
 552   fields_desc = (unsigned char *) SCM_CHARS (layout);
 553   n_fields = data[scm_struct_i_n_words];
 554
 555   SCM_ASSERT (p < n_fields, pos, SCM_OUTOFRANGE, FUNC_NAME);
 556
 557   if (p * 2 < SCM_LENGTH (layout))
 558     {
 559       unsigned char ref;
 560       field_type = fields_desc[p * 2];
 561       ref = fields_desc[p * 2 + 1];
 562       if ((ref != 'r') && (ref != 'w'))
 563         {
 564           if ((ref == 'R') || (ref == 'W'))
 565             field_type = 'u';
 566           else
 567             SCM_ASSERT (0, pos, "ref denied", FUNC_NAME);
 568         }
 569     }
 570   else if (fields_desc[SCM_LENGTH (layout) - 1] != 'O')
 571     field_type = fields_desc[SCM_LENGTH (layout) - 2];
 572   else
 573     {
 574       SCM_ASSERT (0, pos, "ref denied", FUNC_NAME);
 575       abort ();
 576     }
 577
 578   switch (field_type)
 579     {
 580     case 'u':
 581       answer = scm_ulong2num (data[p]);
 582       break;
 583
 584 #if 0
 585     case 'i':
 586       answer = scm_long2num (data[p]);
 587       break;
 588
 589     case 'd':
 590       answer = scm_makdbl (*((double *)&(data[p])), 0.0);
 591       break;
 592 #endif
 593
 594     case 's':
 595     case 'p':
 596       answer = data[p];
 597       break;
 598
 599
 600     default:
 601       SCM_ASSERT (0, SCM_MAKICHR (field_type), "unrecognized field type", FUNC_NAME);
 602       break;
 603     }
 604
 605   return answer;
 606 }
 607 #undef FUNC_NAME
 608
 609
 610 GUILE_PROC (scm_struct_set_x, "struct-set!", 3, 0, 0,
 611             (SCM handle, SCM pos, SCM val),
 612 "")
 613 #define FUNC_NAME s_scm_struct_set_x
 614 {
 615   SCM * data;
 616   SCM layout;
 617   int p;
 618   int n_fields;
 619   unsigned char * fields_desc;
 620   unsigned char field_type = 0;
 621
 622   SCM_VALIDATE_STRUCT(1,handle);
 623   SCM_VALIDATE_INT(2,pos);
 624
 625   layout = SCM_STRUCT_LAYOUT (handle);
 626   data = SCM_STRUCT_DATA (handle);
 627   p = SCM_INUM (pos);
 628
 629   fields_desc = (unsigned char *)SCM_CHARS (layout);
 630   n_fields = data[scm_struct_i_n_words];
 631
 632   SCM_ASSERT (p < n_fields, pos, SCM_OUTOFRANGE, FUNC_NAME);
 633
 634   if (p * 2 < SCM_LENGTH (layout))
 635     {
 636       unsigned char set_x;
 637       field_type = fields_desc[p * 2];
 638       set_x = fields_desc [p * 2 + 1];
 639       if (set_x != 'w')
 640         SCM_ASSERT (0, pos, "set_x denied", FUNC_NAME);
 641     }
 642   else if (fields_desc[SCM_LENGTH (layout) - 1] == 'W')
 643     field_type = fields_desc[SCM_LENGTH (layout) - 2];
 644   else
 645     {
 646       SCM_ASSERT (0, pos, "set_x denied", FUNC_NAME);
 647       abort ();
 648     }
 649
 650   switch (field_type)
 651     {
 652     case 'u':
 653       data[p] = SCM_NUM2ULONG (3,val);
 654       break;
 655
 656 #if 0
 657     case 'i':
 658       data[p] = SCM_NUM2LONG (3,val);
 659       break;
 660
 661     case 'd':
 662       *((double *)&(data[p])) = scm_num2dbl (val, (char *)SCM_ARG3);
 663       break;
 664 #endif
 665
 666     case 'p':
 667       data[p] = val;
 668       break;
 669
 670     case 's':
 671       SCM_ASSERT (0, SCM_MAKICHR (field_type), "self fields immutable", FUNC_NAME);
 672       break;
 673
 674     default:
 675       SCM_ASSERT (0, SCM_MAKICHR (field_type), "unrecognized field type", FUNC_NAME);
 676       break;
 677     }
 678
 679   return val;
 680 }
 681 #undef FUNC_NAME
 682
 683
 684 GUILE_PROC (scm_struct_vtable, "struct-vtable", 1, 0, 0,
 685             (SCM handle),
 686 "Return the vtable structure that describes the type of @var{struct}.")
 687 #define FUNC_NAME s_scm_struct_vtable
 688 {
 689   SCM_VALIDATE_STRUCT(1,handle);
 690   return SCM_STRUCT_VTABLE (handle);
 691 }
 692 #undef FUNC_NAME
 693
 694
 695 GUILE_PROC (scm_struct_vtable_tag, "struct-vtable-tag", 1, 0, 0,
 696             (SCM handle),
 697 "")
 698 #define FUNC_NAME s_scm_struct_vtable_tag
 699 {
 700   SCM_VALIDATE_VTABLE(1,handle);
 701   return scm_long2num ((long) SCM_STRUCT_DATA (handle) >> 3);
 702 }
 703 #undef FUNC_NAME
 704
 705 /* {Associating names and classes with vtables}
 706  *
 707  * The name of a vtable should probably be stored as a slot.  This is
 708  * a backward compatible solution until agreement has been achieved on
 709  * how to associate names with vtables.
 710  */
 711
 712 unsigned int
 713 scm_struct_ihashq (SCM obj, unsigned int n)
 714 {
 715   /* The length of the hash table should be a relative prime it's not
 716      necessary to shift down the address.  */
 717   return obj % n;
 718 }
 719
 720 SCM
 721 scm_struct_create_handle (SCM obj)
 722 {
 723   SCM handle = scm_hash_fn_create_handle_x (scm_struct_table,
 724                                             obj,
 725                                             SCM_BOOL_F,
 726                                             scm_struct_ihashq,
 727                                             scm_sloppy_assq,
 728                                             0);
 729   if (SCM_FALSEP (SCM_CDR (handle)))
 730     SCM_SETCDR (handle, scm_cons (SCM_BOOL_F, SCM_BOOL_F));
 731   return handle;
 732 }
 733
 734 GUILE_PROC (scm_struct_vtable_name, "struct-vtable-name", 1, 0, 0,
 735             (SCM vtable),
 736 "")
 737 #define FUNC_NAME s_scm_struct_vtable_name
 738 {
 739   SCM_VALIDATE_VTABLE(1,vtable);
 740   return SCM_STRUCT_TABLE_NAME (SCM_CDR (scm_struct_create_handle (vtable)));
 741 }
 742 #undef FUNC_NAME
 743
 744 GUILE_PROC (scm_set_struct_vtable_name_x, "set-struct-vtable-name!", 2, 0, 0,
 745             (SCM vtable, SCM name),
 746 "")
 747 #define FUNC_NAME s_scm_set_struct_vtable_name_x
 748 {
 749   SCM_VALIDATE_VTABLE(1,vtable);
 750   SCM_VALIDATE_SYMBOL(2,name);
 751   SCM_SET_STRUCT_TABLE_NAME (SCM_CDR (scm_struct_create_handle (vtable)),
 752                              name);
 753   return SCM_UNSPECIFIED;
 754 }
 755 #undef FUNC_NAME
 756
 757
 758 \f
 759
 760 void
 761 scm_print_struct (SCM exp, SCM port, scm_print_state *pstate)
 762 {
 763   if (SCM_NFALSEP (scm_procedure_p (SCM_STRUCT_PRINTER (exp))))
 764     scm_printer_apply (SCM_STRUCT_PRINTER (exp), exp, port, pstate);
 765   else
 766     {
 767       SCM vtable = SCM_STRUCT_VTABLE (exp);
 768       SCM name = scm_struct_vtable_name (vtable);
 769       scm_puts ("#<", port);
 770       if (SCM_NFALSEP (name))
 771         scm_display (name, port);
 772       else
 773         scm_puts ("struct", port);
 774       scm_putc (' ', port);
 775       scm_intprint (vtable, 16, port);
 776       scm_putc (':', port);
 777       scm_intprint (exp, 16, port);
 778       scm_putc ('>', port);
 779     }
 780 }
 781
 782 void
 783 scm_init_struct ()
 784 {
 785   scm_struct_table
 786     = scm_permanent_object (scm_make_weak_key_hash_table (SCM_MAKINUM (31)));
 787   required_vtable_fields = SCM_CAR (scm_intern_obarray ("pruosrpw", sizeof ("pruosrpw") - 1, SCM_BOOL_F));
 788   scm_permanent_object (required_vtable_fields);
 789   scm_sysintern ("vtable-index-layout", SCM_MAKINUM (scm_vtable_index_layout));
 790   scm_sysintern ("vtable-index-vtable", SCM_MAKINUM (scm_vtable_index_vtable));
 791   scm_sysintern ("vtable-index-printer", SCM_MAKINUM (scm_vtable_index_printer));
 792   scm_sysintern ("vtable-offset-user", SCM_MAKINUM (scm_vtable_offset_user));
 793 #include "struct.x"
 794 }