libguile/struct.c

   1 /*      Copyright (C) 1996, 1997, 1998 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 \f
  42
  43 #include <stdio.h>
  44 #include "_scm.h"
  45 #include "chars.h"
  46 #include "genio.h"
  47 #include "eval.h"
  48 #include "alist.h"
  49 #include "weaks.h"
  50 #include "hashtab.h"
  51
  52 #include "struct.h"
  53
  54 #ifdef HAVE_STRING_H
  55 #include <string.h>
  56 #endif
  57
  58 \f
  59
  60 static SCM required_vtable_fields = SCM_BOOL_F;
  61 static int struct_num = 0;
  62 SCM scm_struct_table;
  63
  64 \f
  65 SCM_PROC (s_struct_make_layout, "make-struct-layout", 1, 0, 0, scm_make_struct_layout);
  66
  67 SCM
  68 scm_make_struct_layout (fields)
  69      SCM fields;
  70 {
  71   SCM new_sym;
  72   SCM_ASSERT (SCM_NIMP (fields) && SCM_ROSTRINGP (fields),
  73               fields, SCM_ARG1, s_struct_make_layout);
  74
  75   {
  76     char * field_desc;
  77     int len;
  78     int x;
  79
  80     len = SCM_ROLENGTH (fields);
  81     field_desc = SCM_ROCHARS (fields);
  82     SCM_ASSERT (!(len & 1), fields, "odd length field specification", s_struct_make_layout);
  83
  84     for (x = 0; x < len; x += 2)
  85       {
  86         switch (field_desc[x])
  87           {
  88           case 'u':
  89           case 'p':
  90 #if 0
  91           case 'i':
  92           case 'd':
  93 #endif
  94           case 's':
  95             break;
  96           default:
  97             SCM_ASSERT (0, SCM_MAKICHR (field_desc[x]) , "unrecognized field type", s_struct_make_layout);
  98           }
  99
 100         switch (field_desc[x + 1])
 101           {
 102           case 'w':
 103             SCM_ASSERT (field_desc[x] != 's', SCM_MAKICHR (field_desc[x + 1]),
 104                         "self fields not writable", s_struct_make_layout);
 105
 106           case 'r':
 107           case 'o':
 108             break;
 109           case 'R':
 110           case 'W':
 111           case 'O':
 112             SCM_ASSERT (field_desc[x] != 's', SCM_MAKICHR (field_desc[x + 1]),
 113                         "self fields not allowed in tail array",
 114                         s_struct_make_layout);
 115             SCM_ASSERT (x == len - 2, SCM_MAKICHR (field_desc[x + 1]),
 116                         "tail array field must be last field in layout",
 117                         s_struct_make_layout);
 118             break;
 119           default:
 120             SCM_ASSERT (0, SCM_MAKICHR (field_desc[x]) , "unrecognized ref specification", s_struct_make_layout);
 121           }
 122 #if 0
 123         if (field_desc[x] == 'd')
 124           {
 125             SCM_ASSERT (field_desc[x + 2] == '-', SCM_MAKINUM (x / 2), "missing dash field", s_struct_make_layout);
 126             x += 2;
 127             goto recheck_ref;
 128           }
 129 #endif
 130       }
 131     new_sym = SCM_CAR (scm_intern_obarray (field_desc, len, SCM_BOOL_F));
 132   }
 133   return scm_return_first (new_sym, fields);
 134 }
 135
 136 \f
 137
 138
 139
 140 void
 141 scm_struct_init (handle, tail_elts, inits)
 142      SCM handle;
 143      int tail_elts;
 144      SCM inits;
 145 {
 146   SCM layout;
 147   SCM * data;
 148   unsigned char * fields_desc;
 149   unsigned char prot = 0;
 150   int n_fields;
 151   SCM * mem;
 152   int tailp = 0;
 153
 154   layout = SCM_STRUCT_LAYOUT (handle);
 155   data = SCM_STRUCT_DATA (handle);
 156   fields_desc = (unsigned char *) SCM_CHARS (layout) - 2;
 157   n_fields = SCM_LENGTH (layout) / 2;
 158   mem = SCM_STRUCT_DATA (handle);
 159   while (n_fields)
 160     {
 161       if (!tailp)
 162         {
 163           fields_desc += 2;
 164           prot = fields_desc[1];
 165           if (SCM_LAYOUT_TAILP (prot))
 166             {
 167               tailp = 1;
 168               prot = prot == 'R' ? 'r' : prot == 'W' ? 'w' : 'o';
 169               *mem++ = tail_elts;
 170               n_fields += tail_elts - 1;
 171               if (n_fields == 0)
 172                 break;
 173             }
 174         }
 175
 176       switch (*fields_desc)
 177         {
 178 #if 0
 179         case 'i':
 180           if ((prot != 'r' && prot != 'w') || inits == SCM_EOL)
 181             *mem = 0;
 182           else
 183             {
 184               *mem = scm_num2long (SCM_CAR (inits), SCM_ARGn, "scm_struct_init");
 185               inits = SCM_CDR (inits);
 186             }
 187           break;
 188 #endif
 189
 190         case 'u':
 191           if ((prot != 'r' && prot != 'w') || inits == SCM_EOL)
 192             *mem = 0;
 193           else
 194             {
 195               *mem = scm_num2ulong (SCM_CAR (inits), SCM_ARGn, "scm_struct_init");
 196               inits = SCM_CDR (inits);
 197             }
 198           break;
 199
 200         case 'p':
 201           if ((prot != 'r' && prot != 'w') || inits == SCM_EOL)
 202             *mem = SCM_BOOL_F;
 203           else
 204             {
 205               *mem = SCM_CAR (inits);
 206               inits = SCM_CDR (inits);
 207             }
 208
 209           break;
 210
 211 #if 0
 212         case 'd':
 213           if ((prot != 'r' && prot != 'w') || inits == SCM_EOL)
 214             *((double *)mem) = 0.0;
 215           else
 216             {
 217               *mem = scm_num2dbl (SCM_CAR (inits), "scm_struct_init");
 218               inits = SCM_CDR (inits);
 219             }
 220           fields_desc += 2;
 221           break;
 222 #endif
 223
 224         case 's':
 225           *mem = handle;
 226           break;
 227         }
 228
 229       n_fields--;
 230       mem++;
 231     }
 232 }
 233
 234
 235 SCM_PROC (s_struct_p, "struct?", 1, 0, 0, scm_struct_p);
 236
 237 SCM
 238 scm_struct_p (x)
 239      SCM x;
 240 {
 241   return ((SCM_NIMP (x) && SCM_STRUCTP (x))
 242           ? SCM_BOOL_T
 243           : SCM_BOOL_F);
 244 }
 245
 246 SCM_PROC (s_struct_vtable_p, "struct-vtable?", 1, 0, 0, scm_struct_vtable_p);
 247
 248 SCM
 249 scm_struct_vtable_p (x)
 250      SCM x;
 251 {
 252   SCM layout;
 253   SCM * mem;
 254
 255   if (SCM_IMP (x))
 256     return SCM_BOOL_F;
 257
 258   if (!SCM_STRUCTP (x))
 259     return SCM_BOOL_F;
 260
 261   layout = SCM_STRUCT_LAYOUT (x);
 262
 263   if (SCM_LENGTH (layout) < SCM_LENGTH (required_vtable_fields))
 264     return SCM_BOOL_F;
 265
 266   if (strncmp (SCM_CHARS (layout), SCM_CHARS (required_vtable_fields),
 267                SCM_LENGTH (required_vtable_fields)))
 268     return SCM_BOOL_F;
 269
 270   mem = SCM_STRUCT_DATA (x);
 271
 272   if (mem[1] != 0)
 273     return SCM_BOOL_F;
 274
 275   if (SCM_IMP (mem[0]))
 276     return SCM_BOOL_F;
 277
 278   return (SCM_SYMBOLP (mem[0])
 279           ? SCM_BOOL_T
 280           : SCM_BOOL_F);
 281 }
 282
 283
 284 /* All struct data must be allocated at an address whose bottom three
 285    bits are zero.  This is because the tag for a struct lives in the
 286    bottom three bits of the struct's car, and the upper bits point to
 287    the data of its vtable, which is a struct itself.  Thus, if the
 288    address of that data doesn't end in three zeros, tagging it will
 289    destroy the pointer.
 290
 291    This function allocates a block of memory, and returns a pointer at
 292    least scm_struct_n_extra_words words into the block.  Furthermore,
 293    it guarantees that that pointer's least three significant bits are
 294    all zero.
 295
 296    The argument n_words should be the number of words that should
 297    appear after the returned address.  (That is, it shouldn't include
 298    scm_struct_n_extra_words.)
 299
 300    This function initializes the following fields of the struct:
 301
 302      scm_struct_i_ptr --- the actual stort of the block of memory; the
 303          address you should pass to 'free' to dispose of the block.
 304          This field allows us to both guarantee that the returned
 305          address is divisible by eight, and allow the GC to free the
 306          block.
 307
 308      scm_struct_i_n_words --- the number of words allocated to the
 309          block, including the extra fields.  This is used by the GC.
 310
 311      scm_struct_i_tag --- a unique tag assigned to this struct,
 312          allocated according to struct_num.
 313
 314      Ugh.  */
 315
 316
 317 SCM *
 318 scm_alloc_struct (int n_words, int n_extra, char *who)
 319 {
 320   int size = sizeof (SCM) * (n_words + n_extra) + 7;
 321   SCM *block = (SCM *) scm_must_malloc (size, who);
 322
 323   /* Adjust the pointer to hide the extra words.  */
 324   SCM *p = block + n_extra;
 325
 326   /* Adjust it even further so it's aligned on an eight-byte boundary.  */
 327   p = (SCM *) (((SCM) p + 7) & ~7);
 328
 329   /* Initialize a few fields as described above, except for the tag.  */
 330   p[scm_struct_i_ptr] = (SCM) block;
 331   p[scm_struct_i_n_words] = (SCM) (n_words + n_extra);
 332
 333   return p;
 334 }
 335
 336
 337 SCM_PROC (s_make_struct, "make-struct", 2, 0, 1, scm_make_struct);
 338
 339 SCM
 340 scm_make_struct (vtable, tail_array_size, init)
 341      SCM vtable;
 342      SCM tail_array_size;
 343      SCM init;
 344 {
 345   SCM layout;
 346   int basic_size;
 347   int tail_elts;
 348   SCM * data;
 349   SCM handle;
 350
 351   SCM_ASSERT ((SCM_BOOL_F != scm_struct_vtable_p (vtable)),
 352               vtable, SCM_ARG1, s_make_struct);
 353   SCM_ASSERT (SCM_INUMP (tail_array_size), tail_array_size, SCM_ARG2,
 354               s_make_struct);
 355
 356   layout = SCM_STRUCT_DATA (vtable)[scm_vtable_index_layout];
 357   basic_size = SCM_LENGTH (layout) / 2;
 358   tail_elts = SCM_INUM (tail_array_size);
 359   SCM_NEWCELL (handle);
 360   SCM_DEFER_INTS;
 361   if (SCM_STRUCT_DATA (vtable)[scm_struct_i_flags] & SCM_STRUCTF_ENTITY)
 362     {
 363       data = scm_alloc_struct (basic_size + tail_elts,
 364                                scm_struct_entity_n_extra_words,
 365                                "make-struct");
 366       data[scm_struct_i_proc + 0] = SCM_BOOL_F;
 367       data[scm_struct_i_proc + 1] = SCM_BOOL_F;
 368       data[scm_struct_i_proc + 2] = SCM_BOOL_F;
 369       data[scm_struct_i_proc + 3] = SCM_BOOL_F;
 370       data[scm_struct_i_setter] = SCM_BOOL_F;
 371     }
 372   else
 373     data = scm_alloc_struct (basic_size + tail_elts,
 374                              scm_struct_n_extra_words,
 375                              "make-struct");
 376   data[scm_struct_i_tag] = struct_num++;
 377   SCM_SETCDR (handle, data);
 378   SCM_SETCAR (handle, ((SCM)SCM_STRUCT_DATA (vtable)) + scm_tc3_cons_gloc);
 379   scm_struct_init (handle, tail_elts, init);
 380   SCM_ALLOW_INTS;
 381   return handle;
 382 }
 383
 384
 385
 386 SCM_PROC (s_make_vtable_vtable, "make-vtable-vtable", 2, 0, 1, scm_make_vtable_vtable);
 387
 388 SCM
 389 scm_make_vtable_vtable (extra_fields, tail_array_size, init)
 390      SCM extra_fields;
 391      SCM tail_array_size;
 392      SCM init;
 393 {
 394   SCM fields;
 395   SCM layout;
 396   int basic_size;
 397   int tail_elts;
 398   SCM * data;
 399   SCM handle;
 400
 401   SCM_ASSERT (SCM_NIMP (extra_fields) && SCM_ROSTRINGP (extra_fields),
 402               extra_fields, SCM_ARG1, s_make_vtable_vtable);
 403   SCM_ASSERT (SCM_INUMP (tail_array_size), tail_array_size, SCM_ARG2,
 404               s_make_vtable_vtable);
 405
 406   fields = scm_string_append (scm_listify (required_vtable_fields,
 407                                            extra_fields,
 408                                            SCM_UNDEFINED));
 409   layout = scm_make_struct_layout (fields);
 410   basic_size = SCM_LENGTH (layout) / 2;
 411   tail_elts = SCM_INUM (tail_array_size);
 412   SCM_NEWCELL (handle);
 413   SCM_DEFER_INTS;
 414   data = scm_alloc_struct (basic_size + tail_elts,
 415                            scm_struct_n_extra_words,
 416                            "make-vtable-vtable");
 417   data[scm_struct_i_tag] = struct_num++;
 418   SCM_SETCDR (handle, data);
 419   SCM_SETCAR (handle, ((SCM)data) + scm_tc3_cons_gloc);
 420   SCM_STRUCT_LAYOUT (handle) = layout;
 421   scm_struct_init (handle, tail_elts, scm_cons (layout, init));
 422   SCM_ALLOW_INTS;
 423   return handle;
 424 }
 425
 426 \f
 427
 428
 429 SCM_PROC (s_struct_ref, "struct-ref", 2, 0, 0, scm_struct_ref);
 430
 431 SCM
 432 scm_struct_ref (handle, pos)
 433      SCM handle;
 434      SCM pos;
 435 {
 436   SCM answer = SCM_UNDEFINED;
 437   SCM * data;
 438   SCM layout;
 439   int p;
 440   int n_fields;
 441   unsigned char * fields_desc;
 442   unsigned char field_type = 0;
 443
 444
 445   SCM_ASSERT (SCM_NIMP (handle) && SCM_STRUCTP (handle), handle,
 446               SCM_ARG1, s_struct_ref);
 447   SCM_ASSERT (SCM_INUMP (pos), pos, SCM_ARG2, s_struct_ref);
 448
 449   layout = SCM_STRUCT_LAYOUT (handle);
 450   data = SCM_STRUCT_DATA (handle);
 451   p = SCM_INUM (pos);
 452
 453   fields_desc = (unsigned char *)SCM_CHARS (layout);
 454   n_fields = data[scm_struct_i_n_words] - scm_struct_n_extra_words;
 455
 456   SCM_ASSERT (p < n_fields, pos, SCM_OUTOFRANGE, s_struct_ref);
 457
 458   if (p * 2 < SCM_LENGTH (layout))
 459     {
 460       unsigned char ref;
 461       field_type = fields_desc[p * 2];
 462       ref = fields_desc[p * 2 + 1];
 463       if ((ref != 'r') && (ref != 'w'))
 464         {
 465           if ((ref == 'R') || (ref == 'W'))
 466             field_type = 'u';
 467           else
 468             SCM_ASSERT (0, pos, "ref denied", s_struct_ref);
 469         }
 470     }
 471   else if (fields_desc[SCM_LENGTH (layout) - 1] != 'O')
 472     field_type = fields_desc[SCM_LENGTH (layout) - 2];
 473   else
 474     {
 475       SCM_ASSERT (0, pos, "ref denied", s_struct_ref);
 476       abort ();
 477     }
 478
 479   switch (field_type)
 480     {
 481     case 'u':
 482       answer = scm_ulong2num (data[p]);
 483       break;
 484
 485 #if 0
 486     case 'i':
 487       answer = scm_long2num (data[p]);
 488       break;
 489
 490     case 'd':
 491       answer = scm_makdbl (*((double *)&(data[p])), 0.0);
 492       break;
 493 #endif
 494
 495     case 's':
 496     case 'p':
 497       answer = data[p];
 498       break;
 499
 500
 501     default:
 502       SCM_ASSERT (0, SCM_MAKICHR (field_type), "unrecognized field type", s_struct_ref);
 503       break;
 504     }
 505
 506   return answer;
 507 }
 508
 509
 510 SCM_PROC (s_struct_set_x, "struct-set!", 3, 0, 0, scm_struct_set_x);
 511
 512 SCM
 513 scm_struct_set_x (handle, pos, val)
 514      SCM handle;
 515      SCM pos;
 516      SCM val;
 517 {
 518   SCM * data;
 519   SCM layout;
 520   int p;
 521   int n_fields;
 522   unsigned char * fields_desc;
 523   unsigned char field_type = 0;
 524
 525
 526
 527   SCM_ASSERT (SCM_NIMP (handle) && SCM_STRUCTP (handle), handle,
 528               SCM_ARG1, s_struct_ref);
 529   SCM_ASSERT (SCM_INUMP (pos), pos, SCM_ARG2, s_struct_ref);
 530
 531   layout = SCM_STRUCT_LAYOUT (handle);
 532   data = SCM_STRUCT_DATA (handle);
 533   p = SCM_INUM (pos);
 534
 535   fields_desc = (unsigned char *)SCM_CHARS (layout);
 536   n_fields = data[scm_struct_i_n_words] - scm_struct_n_extra_words;
 537
 538   SCM_ASSERT (p < n_fields, pos, SCM_OUTOFRANGE, s_struct_set_x);
 539
 540   if (p * 2 < SCM_LENGTH (layout))
 541     {
 542       unsigned char set_x;
 543       field_type = fields_desc[p * 2];
 544       set_x = fields_desc [p * 2 + 1];
 545       if (set_x != 'w')
 546         SCM_ASSERT (0, pos, "set_x denied", s_struct_set_x);
 547     }
 548   else if (fields_desc[SCM_LENGTH (layout) - 1] == 'W')
 549     field_type = fields_desc[SCM_LENGTH (layout) - 2];
 550   else
 551     {
 552       SCM_ASSERT (0, pos, "set_x denied", s_struct_ref);
 553       abort ();
 554     }
 555
 556   switch (field_type)
 557     {
 558     case 'u':
 559       data[p] = (SCM)scm_num2ulong (val, (char *)SCM_ARG3, s_struct_set_x);
 560       break;
 561
 562 #if 0
 563     case 'i':
 564       data[p] = scm_num2long (val, (char *)SCM_ARG3, s_struct_set_x);
 565       break;
 566
 567     case 'd':
 568       *((double *)&(data[p])) = scm_num2dbl (val, (char *)SCM_ARG3);
 569       break;
 570 #endif
 571
 572     case 'p':
 573       data[p] = val;
 574       break;
 575
 576     case 's':
 577       SCM_ASSERT (0, SCM_MAKICHR (field_type), "self fields immutable", s_struct_set_x);
 578       break;
 579
 580     default:
 581       SCM_ASSERT (0, SCM_MAKICHR (field_type), "unrecognized field type", s_struct_set_x);
 582       break;
 583     }
 584
 585   return val;
 586 }
 587
 588
 589 SCM_PROC (s_struct_vtable, "struct-vtable", 1, 0, 0, scm_struct_vtable);
 590
 591 SCM
 592 scm_struct_vtable (handle)
 593      SCM handle;
 594 {
 595   SCM_ASSERT (SCM_NIMP (handle) && SCM_STRUCTP (handle), handle,
 596               SCM_ARG1, s_struct_vtable);
 597   return SCM_STRUCT_VTABLE (handle);
 598 }
 599
 600
 601 SCM_PROC (s_struct_vtable_tag, "struct-vtable-tag", 1, 0, 0, scm_struct_vtable_tag);
 602
 603 SCM
 604 scm_struct_vtable_tag (handle)
 605      SCM handle;
 606 {
 607   SCM_ASSERT (SCM_NFALSEP (scm_struct_vtable_p (handle)),
 608               handle, SCM_ARG1, s_struct_vtable_tag);
 609   return scm_long2num (SCM_STRUCT_DATA (handle)[scm_struct_i_tag]);
 610 }
 611
 612 /* {Associating names and classes with vtables}
 613  *
 614  * The name of a vtable should probably be stored as a slot.  This is
 615  * a backward compatible solution until agreement has been achieved on
 616  * how to associate names with vtables.
 617  */
 618
 619 unsigned int
 620 scm_struct_ihashq (SCM obj, unsigned int n)
 621 {
 622   return (SCM_STRUCT_DATA (obj)[scm_struct_i_tag] & ~SCM_STRUCTF_MASK) % n;
 623 }
 624
 625 SCM
 626 scm_struct_create_handle (SCM obj)
 627 {
 628   SCM handle = scm_hash_fn_create_handle_x (scm_struct_table,
 629                                             obj,
 630                                             SCM_BOOL_F,
 631                                             scm_struct_ihashq,
 632                                             scm_sloppy_assq,
 633                                             0);
 634   if (SCM_FALSEP (SCM_CDR (handle)))
 635     SCM_SETCDR (handle, scm_cons (SCM_BOOL_F, SCM_BOOL_F));
 636   return handle;
 637 }
 638
 639 SCM_PROC (s_struct_vtable_name, "struct-vtable-name", 1, 0, 0, scm_struct_vtable_name);
 640
 641 SCM
 642 scm_struct_vtable_name (SCM vtable)
 643 {
 644   SCM_ASSERT (SCM_NFALSEP (scm_struct_vtable_p (vtable)),
 645               vtable, SCM_ARG1, s_struct_vtable_name);
 646
 647   return SCM_STRUCT_TABLE_NAME (SCM_CDR (scm_struct_create_handle (vtable)));
 648 }
 649
 650 SCM_PROC (s_set_struct_vtable_name_x, "set-struct-vtable-name!", 2, 0, 0, scm_set_struct_vtable_name_x);
 651
 652 SCM
 653 scm_set_struct_vtable_name_x (SCM vtable, SCM name)
 654 {
 655   SCM_ASSERT (SCM_NIMP (vtable) && SCM_NFALSEP (scm_struct_vtable_p (vtable)),
 656               vtable, SCM_ARG1, s_set_struct_vtable_name_x);
 657   SCM_ASSERT (SCM_NIMP (name) && SCM_SYMBOLP (name),
 658               name, SCM_ARG2, s_set_struct_vtable_name_x);
 659   SCM_SET_STRUCT_TABLE_NAME (SCM_CDR (scm_struct_create_handle (vtable)),
 660                              name);
 661   return SCM_UNSPECIFIED;
 662 }
 663
 664
 665 \f
 666
 667 void
 668 scm_print_struct (exp, port, pstate)
 669      SCM exp;
 670      SCM port;
 671      scm_print_state *pstate;
 672 {
 673   if (SCM_NFALSEP (scm_procedure_p (SCM_STRUCT_PRINTER (exp))))
 674     scm_printer_apply (SCM_STRUCT_PRINTER (exp), exp, port, pstate);
 675   else
 676     {
 677       scm_lfwrite ("#<struct ", sizeof ("#<struct ") - 1, port);
 678       scm_intprint (SCM_STRUCT_VTABLE (exp), 16, port);
 679       scm_putc (':', port);
 680       scm_intprint (exp, 16, port);
 681       scm_putc ('>', port);
 682     }
 683 }
 684
 685 void
 686 scm_init_struct ()
 687 {
 688   scm_struct_table
 689     = scm_permanent_object (scm_make_weak_key_hash_table (SCM_MAKINUM (31)));
 690   required_vtable_fields = SCM_CAR (scm_intern_obarray ("pruosrpw", sizeof ("pruosrpw") - 1, SCM_BOOL_F));
 691   scm_permanent_object (required_vtable_fields);
 692   scm_sysintern ("vtable-index-layout", SCM_MAKINUM (scm_vtable_index_layout));
 693   scm_sysintern ("vtable-index-vtable", SCM_MAKINUM (scm_vtable_index_vtable));
 694   scm_sysintern ("vtable-index-printer", SCM_MAKINUM (scm_vtable_index_printer));
 695   scm_sysintern ("vtable-offset-user", SCM_MAKINUM (scm_vtable_offset_user));
 696 #include "struct.x"
 697 }