libguile/struct.c

   1 /* Copyright (C) 1996,1997,1998,1999,2000,2001, 2003 Free Software Foundation, Inc.
   2  *
   3  * This library is free software; you can redistribute it and/or
   4  * modify it under the terms of the GNU Lesser General Public
   5  * License as published by the Free Software Foundation; either
   6  * version 2.1 of the License, or (at your option) any later version.
   7  *
   8  * This library 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 GNU
  11  * Lesser General Public License for more details.
  12  *
  13  * You should have received a copy of the GNU Lesser General Public
  14  * License along with this library; if not, write to the Free Software
  15  * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
  16  */
  17
  18 \f
  19 #if HAVE_CONFIG_H
  20 #  include <config.h>
  21 #endif
  22
  23 #include "libguile/_scm.h"
  24 #include "libguile/chars.h"
  25 #include "libguile/eval.h"
  26 #include "libguile/alist.h"
  27 #include "libguile/weaks.h"
  28 #include "libguile/hashtab.h"
  29 #include "libguile/ports.h"
  30 #include "libguile/strings.h"
  31
  32 #include "libguile/validate.h"
  33 #include "libguile/struct.h"
  34
  35 #ifdef HAVE_STRING_H
  36 #include <string.h>
  37 #endif
  38
  39 \f
  40
  41 static SCM required_vtable_fields = SCM_BOOL_F;
  42 SCM scm_struct_table;
  43
  44 \f
  45 SCM_DEFINE (scm_make_struct_layout, "make-struct-layout", 1, 0, 0,
  46             (SCM fields),
  47             "Return a new structure layout object.\n\n"
  48             "@var{fields} must be a string made up of pairs of characters\n"
  49             "strung together.  The first character of each pair describes a field\n"
  50             "type, the second a field protection.  Allowed types are 'p' for\n"
  51             "GC-protected Scheme data, 'u' for unprotected binary data, and 's' for\n"
  52             "a field that points to the structure itself.    Allowed protections\n"
  53             "are 'w' for mutable fields, 'r' for read-only fields, and 'o' for opaque\n"
  54             "fields.  The last field protection specification may be capitalized to\n"
  55             "indicate that the field is a tail-array.")
  56 #define FUNC_NAME s_scm_make_struct_layout
  57 {
  58   SCM new_sym;
  59   SCM_VALIDATE_STRING (1, fields);
  60
  61   { /* scope */
  62     char * field_desc;
  63     size_t len;
  64     int x;
  65
  66     len = SCM_STRING_LENGTH (fields);
  67     if (len % 2 == 1)
  68       SCM_MISC_ERROR ("odd length field specification: ~S",
  69                       scm_list_1 (fields));
  70
  71     field_desc = SCM_STRING_CHARS (fields);
  72
  73     for (x = 0; x < len; x += 2)
  74       {
  75         switch (field_desc[x])
  76           {
  77           case 'u':
  78           case 'p':
  79 #if 0
  80           case 'i':
  81           case 'd':
  82 #endif
  83           case 's':
  84             break;
  85           default:
  86             SCM_MISC_ERROR ("unrecognized field type: ~S",
  87                             scm_list_1 (SCM_MAKE_CHAR (field_desc[x])));
  88           }
  89
  90         switch (field_desc[x + 1])
  91           {
  92           case 'w':
  93             if (field_desc[x] == 's')
  94               SCM_MISC_ERROR ("self fields not writable", SCM_EOL);
  95           case 'r':
  96           case 'o':
  97             break;
  98           case 'R':
  99           case 'W':
 100           case 'O':
 101             if (field_desc[x] == 's')
 102               SCM_MISC_ERROR ("self fields not allowed in tail array",
 103                               SCM_EOL);
 104             if (x != len - 2)
 105               SCM_MISC_ERROR ("tail array field must be last field in layout",
 106                               SCM_EOL);
 107             break;
 108           default:
 109             SCM_MISC_ERROR ("unrecognized ref specification: ~S",
 110                             scm_list_1 (SCM_MAKE_CHAR (field_desc[x + 1])));
 111           }
 112 #if 0
 113         if (field_desc[x] == 'd')
 114           {
 115             if (field_desc[x + 2] != '-')
 116               SCM_MISC_ERROR ("missing dash field at position ~A",
 117                               scm_list_1 (SCM_MAKINUM (x / 2)));
 118             x += 2;
 119             goto recheck_ref;
 120           }
 121 #endif
 122       }
 123     new_sym = scm_mem2symbol (field_desc, len);
 124   }
 125   return scm_return_first (new_sym, fields);
 126 }
 127 #undef FUNC_NAME
 128
 129 \f
 130
 131
 132
 133 static void
 134 scm_struct_init (SCM handle, SCM layout, scm_t_bits * mem, int tail_elts, SCM inits)
 135 {
 136   unsigned char * fields_desc = (unsigned char *) SCM_SYMBOL_CHARS (layout) - 2;
 137   unsigned char prot = 0;
 138   int n_fields = SCM_SYMBOL_LENGTH (layout) / 2;
 139   int tailp = 0;
 140
 141   while (n_fields)
 142     {
 143       if (!tailp)
 144         {
 145           fields_desc += 2;
 146           prot = fields_desc[1];
 147           if (SCM_LAYOUT_TAILP (prot))
 148             {
 149               tailp = 1;
 150               prot = prot == 'R' ? 'r' : prot == 'W' ? 'w' : 'o';
 151               *mem++ = tail_elts;
 152               n_fields += tail_elts - 1;
 153               if (n_fields == 0)
 154                 break;
 155             }
 156         }
 157
 158       switch (*fields_desc)
 159         {
 160 #if 0
 161         case 'i':
 162           if ((prot != 'r' && prot != 'w') || inits == SCM_EOL)
 163             *mem = 0;
 164           else
 165             {
 166               *mem = scm_num2long (SCM_CAR (inits), SCM_ARGn, "scm_struct_init");
 167               inits = SCM_CDR (inits);
 168             }
 169           break;
 170 #endif
 171
 172         case 'u':
 173           if ((prot != 'r' && prot != 'w') || SCM_NULLP (inits))
 174             *mem = 0;
 175           else
 176             {
 177               *mem = scm_num2ulong (SCM_CAR (inits),
 178                                     SCM_ARGn,
 179                                     "scm_struct_init");
 180               inits = SCM_CDR (inits);
 181             }
 182           break;
 183
 184         case 'p':
 185           if ((prot != 'r' && prot != 'w') || SCM_NULLP (inits))
 186             *mem = SCM_UNPACK (SCM_BOOL_F);
 187           else
 188             {
 189               *mem = SCM_UNPACK (SCM_CAR (inits));
 190               inits = SCM_CDR (inits);
 191             }
 192
 193           break;
 194
 195 #if 0
 196         case 'd':
 197           if ((prot != 'r' && prot != 'w') || inits == SCM_EOL)
 198             *((double *)mem) = 0.0;
 199           else
 200             {
 201               *mem = scm_num2dbl (SCM_CAR (inits), "scm_struct_init");
 202               inits = SCM_CDR (inits);
 203             }
 204           fields_desc += 2;
 205           break;
 206 #endif
 207
 208         case 's':
 209           *mem = SCM_UNPACK (handle);
 210           break;
 211         }
 212
 213       n_fields--;
 214       mem++;
 215     }
 216 }
 217
 218
 219 SCM_DEFINE (scm_struct_p, "struct?", 1, 0, 0,
 220             (SCM x),
 221             "Return @code{#t} iff @var{x} is a structure object, else\n"
 222             "@code{#f}.")
 223 #define FUNC_NAME s_scm_struct_p
 224 {
 225   return scm_from_bool(SCM_STRUCTP (x));
 226 }
 227 #undef FUNC_NAME
 228
 229 SCM_DEFINE (scm_struct_vtable_p, "struct-vtable?", 1, 0, 0,
 230             (SCM x),
 231             "Return @code{#t} iff @var{x} is a vtable structure.")
 232 #define FUNC_NAME s_scm_struct_vtable_p
 233 {
 234   SCM layout;
 235   scm_t_bits * mem;
 236
 237   if (!SCM_STRUCTP (x))
 238     return SCM_BOOL_F;
 239
 240   layout = SCM_STRUCT_LAYOUT (x);
 241
 242   if (SCM_SYMBOL_LENGTH (layout) < SCM_STRING_LENGTH (required_vtable_fields))
 243     return SCM_BOOL_F;
 244
 245   if (strncmp (SCM_SYMBOL_CHARS (layout), SCM_STRING_CHARS (required_vtable_fields),
 246                SCM_STRING_LENGTH (required_vtable_fields)))
 247     return SCM_BOOL_F;
 248
 249   mem = SCM_STRUCT_DATA (x);
 250
 251   return scm_from_bool (SCM_SYMBOLP (SCM_PACK (mem[scm_vtable_index_layout])));
 252 }
 253 #undef FUNC_NAME
 254
 255
 256 /* All struct data must be allocated at an address whose bottom three
 257    bits are zero.  This is because the tag for a struct lives in the
 258    bottom three bits of the struct's car, and the upper bits point to
 259    the data of its vtable, which is a struct itself.  Thus, if the
 260    address of that data doesn't end in three zeros, tagging it will
 261    destroy the pointer.
 262
 263    This function allocates a block of memory, and returns a pointer at
 264    least scm_struct_n_extra_words words into the block.  Furthermore,
 265    it guarantees that that pointer's least three significant bits are
 266    all zero.
 267
 268    The argument n_words should be the number of words that should
 269    appear after the returned address.  (That is, it shouldn't include
 270    scm_struct_n_extra_words.)
 271
 272    This function initializes the following fields of the struct:
 273
 274      scm_struct_i_ptr --- the actual start of the block of memory; the
 275          address you should pass to 'free' to dispose of the block.
 276          This field allows us to both guarantee that the returned
 277          address is divisible by eight, and allow the GC to free the
 278          block.
 279
 280      scm_struct_i_n_words --- the number of words allocated to the
 281          block, including the extra fields.  This is used by the GC.
 282
 283      Ugh.  */
 284
 285
 286 scm_t_bits *
 287 scm_alloc_struct (int n_words, int n_extra, const char *what)
 288 {
 289   int size = sizeof (scm_t_bits) * (n_words + n_extra) + 7;
 290   void * block = scm_gc_malloc (size, what);
 291
 292   /* Adjust the pointer to hide the extra words.  */
 293   scm_t_bits * p = (scm_t_bits *) block + n_extra;
 294
 295   /* Adjust it even further so it's aligned on an eight-byte boundary.  */
 296   p = (scm_t_bits *) (((scm_t_bits) p + 7) & ~7);
 297
 298   /* Initialize a few fields as described above.  */
 299   p[scm_struct_i_free] = (scm_t_bits) scm_struct_free_standard;
 300   p[scm_struct_i_ptr] = (scm_t_bits) block;
 301   p[scm_struct_i_n_words] = n_words;
 302   p[scm_struct_i_flags] = 0;
 303
 304   return p;
 305 }
 306
 307 void
 308 scm_struct_free_0 (scm_t_bits * vtable SCM_UNUSED,
 309                    scm_t_bits * data SCM_UNUSED)
 310 {
 311 }
 312
 313 void
 314 scm_struct_free_light (scm_t_bits * vtable, scm_t_bits * data)
 315 {
 316   size_t n = vtable [scm_struct_i_size] & ~SCM_STRUCTF_MASK;
 317   scm_gc_free (data, n, "struct");
 318 }
 319
 320 void
 321 scm_struct_free_standard (scm_t_bits * vtable SCM_UNUSED, scm_t_bits * data)
 322 {
 323   size_t n = (data[scm_struct_i_n_words] + scm_struct_n_extra_words)
 324              * sizeof (scm_t_bits) + 7;
 325   scm_gc_free ((void *) data[scm_struct_i_ptr], n, "heavy struct");
 326 }
 327
 328 void
 329 scm_struct_free_entity (scm_t_bits * vtable SCM_UNUSED, scm_t_bits * data)
 330 {
 331   size_t n = (data[scm_struct_i_n_words] + scm_struct_entity_n_extra_words)
 332              * sizeof (scm_t_bits) + 7;
 333   scm_gc_free ((void *) data[scm_struct_i_ptr], n, "entity struct");
 334 }
 335
 336 static void *
 337 scm_struct_gc_init (void *dummy1 SCM_UNUSED,
 338                     void *dummy2 SCM_UNUSED,
 339                     void *dummy3 SCM_UNUSED)
 340 {
 341   scm_i_structs_to_free = SCM_EOL;
 342   return 0;
 343 }
 344
 345 static void *
 346 scm_free_structs (void *dummy1 SCM_UNUSED,
 347                   void *dummy2 SCM_UNUSED,
 348                   void *dummy3 SCM_UNUSED)
 349 {
 350   SCM newchain = scm_i_structs_to_free;
 351   do
 352     {
 353       /* Mark vtables in GC chain.  GC mark set means delay freeing. */
 354       SCM chain = newchain;
 355       while (!SCM_NULLP (chain))
 356         {
 357           SCM vtable = SCM_STRUCT_VTABLE (chain);
 358           if (SCM_STRUCT_GC_CHAIN (vtable) != 0 && vtable != chain)
 359             SCM_SET_GC_MARK (vtable);
 360           chain = SCM_STRUCT_GC_CHAIN (chain);
 361         }
 362       /* Free unmarked structs.  */
 363       chain = newchain;
 364       newchain = SCM_EOL;
 365       while (!SCM_NULLP (chain))
 366         {
 367           SCM obj = chain;
 368           chain = SCM_STRUCT_GC_CHAIN (chain);
 369           if (SCM_GC_MARK_P (obj))
 370             {
 371               SCM_CLEAR_GC_MARK (obj);
 372               SCM_SET_STRUCT_GC_CHAIN (obj, newchain);
 373               newchain = obj;
 374             }
 375           else
 376             {
 377               /* XXX - use less explicit code. */
 378               scm_t_bits word0 = SCM_CELL_WORD_0 (obj) - scm_tc3_struct;
 379               scm_t_bits * vtable_data = (scm_t_bits *) word0;
 380               scm_t_bits * data = SCM_STRUCT_DATA (obj);
 381               scm_t_struct_free free_struct_data
 382                 = ((scm_t_struct_free) vtable_data[scm_struct_i_free]);
 383               SCM_SET_CELL_TYPE (obj, scm_tc_free_cell);
 384               free_struct_data (vtable_data, data);
 385             }
 386         }
 387     }
 388   while (!SCM_NULLP (newchain));
 389   return 0;
 390 }
 391
 392 SCM_DEFINE (scm_make_struct, "make-struct", 2, 0, 1,
 393             (SCM vtable, SCM tail_array_size, SCM init),
 394             "Create a new structure.\n\n"
 395             "@var{type} must be a vtable structure (@pxref{Vtables}).\n\n"
 396             "@var{tail-elts} must be a non-negative integer.  If the layout\n"
 397             "specification indicated by @var{type} includes a tail-array,\n"
 398             "this is the number of elements allocated to that array.\n\n"
 399             "The @var{init1}, @dots{} are optional arguments describing how\n"
 400             "successive fields of the structure should be initialized.  Only fields\n"
 401             "with protection 'r' or 'w' can be initialized, except for fields of\n"
 402             "type 's', which are automatically initialized to point to the new\n"
 403             "structure itself; fields with protection 'o' can not be initialized by\n"
 404             "Scheme programs.\n\n"
 405             "If fewer optional arguments than initializable fields are supplied,\n"
 406             "fields of type 'p' get default value #f while fields of type 'u' are\n"
 407             "initialized to 0.\n\n"
 408             "Structs are currently the basic representation for record-like data\n"
 409             "structures in Guile.  The plan is to eventually replace them with a\n"
 410             "new representation which will at the same time be easier to use and\n"
 411             "more powerful.\n\n"
 412             "For more information, see the documentation for @code{make-vtable-vtable}.")
 413 #define FUNC_NAME s_scm_make_struct
 414 {
 415   SCM layout;
 416   int basic_size;
 417   int tail_elts;
 418   scm_t_bits * data;
 419   SCM handle;
 420
 421   SCM_VALIDATE_VTABLE (1, vtable);
 422   SCM_VALIDATE_INUM (2, tail_array_size);
 423   SCM_VALIDATE_REST_ARGUMENT (init);
 424
 425   layout = SCM_PACK (SCM_STRUCT_DATA (vtable) [scm_vtable_index_layout]);
 426   basic_size = SCM_SYMBOL_LENGTH (layout) / 2;
 427   tail_elts = SCM_INUM (tail_array_size);
 428   SCM_DEFER_INTS;
 429   if (SCM_STRUCT_DATA (vtable)[scm_struct_i_flags] & SCM_STRUCTF_ENTITY)
 430     {
 431       data = scm_alloc_struct (basic_size + tail_elts,
 432                                scm_struct_entity_n_extra_words,
 433                                "entity struct");
 434       data[scm_struct_i_procedure] = SCM_UNPACK (SCM_BOOL_F);
 435       data[scm_struct_i_setter] = SCM_UNPACK (SCM_BOOL_F);
 436     }
 437   else
 438     data = scm_alloc_struct (basic_size + tail_elts,
 439                              scm_struct_n_extra_words,
 440                              "struct");
 441   handle = scm_double_cell ((((scm_t_bits) SCM_STRUCT_DATA (vtable))
 442                              + scm_tc3_struct),
 443                             (scm_t_bits) data, 0, 0);
 444   scm_struct_init (handle, layout, data, tail_elts, init);
 445   SCM_ALLOW_INTS;
 446   return handle;
 447 }
 448 #undef FUNC_NAME
 449
 450
 451
 452 SCM_DEFINE (scm_make_vtable_vtable, "make-vtable-vtable", 2, 0, 1,
 453             (SCM user_fields, SCM tail_array_size, SCM init),
 454             "Return a new, self-describing vtable structure.\n\n"
 455             "@var{user-fields} is a string describing user defined fields of the\n"
 456             "vtable beginning at index @code{vtable-offset-user}\n"
 457             "(see @code{make-struct-layout}).\n\n"
 458             "@var{tail-size} specifies the size of the tail-array (if any) of\n"
 459             "this vtable.\n\n"
 460             "@var{init1}, @dots{} are the optional initializers for the fields of\n"
 461             "the vtable.\n\n"
 462             "Vtables have one initializable system field---the struct printer.\n"
 463             "This field comes before the user fields in the initializers passed\n"
 464             "to @code{make-vtable-vtable} and @code{make-struct}, and thus works as\n"
 465             "a third optional argument to @code{make-vtable-vtable} and a fourth to\n"
 466             "@code{make-struct} when creating vtables:\n\n"
 467             "If the value is a procedure, it will be called instead of the standard\n"
 468             "printer whenever a struct described by this vtable is printed.\n"
 469             "The procedure will be called with arguments STRUCT and PORT.\n\n"
 470             "The structure of a struct is described by a vtable, so the vtable is\n"
 471             "in essence the type of the struct.  The vtable is itself a struct with\n"
 472             "a vtable.  This could go on forever if it weren't for the\n"
 473             "vtable-vtables which are self-describing vtables, and thus terminate\n"
 474             "the chain.\n\n"
 475             "There are several potential ways of using structs, but the standard\n"
 476             "one is to use three kinds of structs, together building up a type\n"
 477             "sub-system: one vtable-vtable working as the root and one or several\n"
 478             "\"types\", each with a set of \"instances\".  (The vtable-vtable should be\n"
 479             "compared to the class <class> which is the class of itself.)\n\n"
 480             "@lisp\n"
 481             "(define ball-root (make-vtable-vtable \"pr\" 0))\n\n"
 482             "(define (make-ball-type ball-color)\n"
 483             "  (make-struct ball-root 0\n"
 484             "          (make-struct-layout \"pw\")\n"
 485             "               (lambda (ball port)\n"
 486             "                 (format port \"#<a ~A ball owned by ~A>\"\n"
 487             "                         (color ball)\n"
 488             "                         (owner ball)))\n"
 489             "               ball-color))\n"
 490             "(define (color ball) (struct-ref (struct-vtable ball) vtable-offset-user))\n"
 491             "(define (owner ball) (struct-ref ball 0))\n\n"
 492             "(define red (make-ball-type 'red))\n"
 493             "(define green (make-ball-type 'green))\n\n"
 494             "(define (make-ball type owner) (make-struct type 0 owner))\n\n"
 495             "(define ball (make-ball green 'Nisse))\n"
 496             "ball @result{} #<a green ball owned by Nisse>\n"
 497             "@end lisp")
 498 #define FUNC_NAME s_scm_make_vtable_vtable
 499 {
 500   SCM fields;
 501   SCM layout;
 502   int basic_size;
 503   int tail_elts;
 504   scm_t_bits * data;
 505   SCM handle;
 506
 507   SCM_VALIDATE_STRING (1, user_fields);
 508   SCM_VALIDATE_INUM (2, tail_array_size);
 509   SCM_VALIDATE_REST_ARGUMENT (init);
 510
 511   fields = scm_string_append (scm_list_2 (required_vtable_fields,
 512                                           user_fields));
 513   layout = scm_make_struct_layout (fields);
 514   basic_size = SCM_SYMBOL_LENGTH (layout) / 2;
 515   tail_elts = SCM_INUM (tail_array_size);
 516   SCM_DEFER_INTS;
 517   data = scm_alloc_struct (basic_size + tail_elts,
 518                            scm_struct_n_extra_words,
 519                            "struct");
 520   handle = scm_double_cell ((scm_t_bits) data + scm_tc3_struct,
 521                             (scm_t_bits) data, 0, 0);
 522   data [scm_vtable_index_layout] = SCM_UNPACK (layout);
 523   scm_struct_init (handle, layout, data, tail_elts, scm_cons (layout, init));
 524   SCM_ALLOW_INTS;
 525   return handle;
 526 }
 527 #undef FUNC_NAME
 528
 529 \f
 530
 531
 532 SCM_DEFINE (scm_struct_ref, "struct-ref", 2, 0, 0,
 533             (SCM handle, SCM pos),
 534             "@deffnx {Scheme Procedure} struct-set! struct n value\n"
 535             "Access (or modify) the @var{n}th field of @var{struct}.\n\n"
 536             "If the field is of type 'p', then it can be set to an arbitrary value.\n\n"
 537             "If the field is of type 'u', then it can only be set to a non-negative\n"
 538             "integer value small enough to fit in one machine word.")
 539 #define FUNC_NAME s_scm_struct_ref
 540 {
 541   SCM answer = SCM_UNDEFINED;
 542   scm_t_bits * data;
 543   SCM layout;
 544   int p;
 545   scm_t_bits n_fields;
 546   char * fields_desc;
 547   char field_type = 0;
 548
 549
 550   SCM_VALIDATE_STRUCT (1, handle);
 551   SCM_VALIDATE_INUM (2, pos);
 552
 553   layout = SCM_STRUCT_LAYOUT (handle);
 554   data = SCM_STRUCT_DATA (handle);
 555   p = SCM_INUM (pos);
 556
 557   fields_desc = SCM_SYMBOL_CHARS (layout);
 558   n_fields = data[scm_struct_i_n_words];
 559
 560   SCM_ASSERT_RANGE(1, pos, p < n_fields);
 561
 562   if (p * 2 < SCM_SYMBOL_LENGTH (layout))
 563     {
 564       char ref;
 565       field_type = fields_desc[p * 2];
 566       ref = fields_desc[p * 2 + 1];
 567       if ((ref != 'r') && (ref != 'w'))
 568         {
 569           if ((ref == 'R') || (ref == 'W'))
 570             field_type = 'u';
 571           else
 572             SCM_MISC_ERROR ("ref denied for field ~A", scm_list_1 (pos));
 573         }
 574     }
 575   else if (fields_desc[SCM_SYMBOL_LENGTH (layout) - 1] != 'O')
 576     field_type = fields_desc[SCM_SYMBOL_LENGTH (layout) - 2];
 577   else
 578     SCM_MISC_ERROR ("ref denied for field ~A", scm_list_1 (pos));
 579
 580   switch (field_type)
 581     {
 582     case 'u':
 583       answer = scm_ulong2num (data[p]);
 584       break;
 585
 586 #if 0
 587     case 'i':
 588       answer = scm_long2num (data[p]);
 589       break;
 590
 591     case 'd':
 592       answer = scm_make_real (*((double *)&(data[p])));
 593       break;
 594 #endif
 595
 596     case 's':
 597     case 'p':
 598       answer = SCM_PACK (data[p]);
 599       break;
 600
 601
 602     default:
 603       SCM_MISC_ERROR ("unrecognized field type: ~S",
 604                       scm_list_1 (SCM_MAKE_CHAR (field_type)));
 605     }
 606
 607   return answer;
 608 }
 609 #undef FUNC_NAME
 610
 611
 612 SCM_DEFINE (scm_struct_set_x, "struct-set!", 3, 0, 0,
 613             (SCM handle, SCM pos, SCM val),
 614             "Set the slot of the structure @var{handle} with index @var{pos}\n"
 615             "to @var{val}.  Signal an error if the slot can not be written\n"
 616             "to.")
 617 #define FUNC_NAME s_scm_struct_set_x
 618 {
 619   scm_t_bits * data;
 620   SCM layout;
 621   int p;
 622   int n_fields;
 623   char * fields_desc;
 624   char field_type = 0;
 625
 626   SCM_VALIDATE_STRUCT (1, handle);
 627   SCM_VALIDATE_INUM (2, pos);
 628
 629   layout = SCM_STRUCT_LAYOUT (handle);
 630   data = SCM_STRUCT_DATA (handle);
 631   p = SCM_INUM (pos);
 632
 633   fields_desc = SCM_SYMBOL_CHARS (layout);
 634   n_fields = data[scm_struct_i_n_words];
 635
 636   SCM_ASSERT_RANGE (1, pos, p < n_fields);
 637
 638   if (p * 2 < SCM_SYMBOL_LENGTH (layout))
 639     {
 640       char set_x;
 641       field_type = fields_desc[p * 2];
 642       set_x = fields_desc [p * 2 + 1];
 643       if (set_x != 'w')
 644         SCM_MISC_ERROR ("set! denied for field ~A", scm_list_1 (pos));
 645     }
 646   else if (fields_desc[SCM_SYMBOL_LENGTH (layout) - 1] == 'W')
 647     field_type = fields_desc[SCM_SYMBOL_LENGTH (layout) - 2];
 648   else
 649     SCM_MISC_ERROR ("set! denied for field ~A", scm_list_1 (pos));
 650
 651   switch (field_type)
 652     {
 653     case 'u':
 654       data[p] = SCM_NUM2ULONG (3, val);
 655       break;
 656
 657 #if 0
 658     case 'i':
 659       data[p] = SCM_NUM2LONG (3, val);
 660       break;
 661
 662     case 'd':
 663       *((double *)&(data[p])) = scm_num2dbl (val, (char *)SCM_ARG3);
 664       break;
 665 #endif
 666
 667     case 'p':
 668       data[p] = SCM_UNPACK (val);
 669       break;
 670
 671     case 's':
 672       SCM_MISC_ERROR ("self fields immutable", SCM_EOL);
 673
 674     default:
 675       SCM_MISC_ERROR ("unrecognized field type: ~S",
 676                       scm_list_1 (SCM_MAKE_CHAR (field_type)));
 677     }
 678
 679   return val;
 680 }
 681 #undef FUNC_NAME
 682
 683
 684 SCM_DEFINE (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 SCM_DEFINE (scm_struct_vtable_tag, "struct-vtable-tag", 1, 0, 0,
 696             (SCM handle),
 697             "Return the vtable tag of the structure @var{handle}.")
 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 long
 713 scm_struct_ihashq (SCM obj, unsigned long 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 SCM_UNPACK (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_is_false (SCM_CDR (handle)))
 730     SCM_SETCDR (handle, scm_cons (SCM_BOOL_F, SCM_BOOL_F));
 731   return handle;
 732 }
 733
 734 SCM_DEFINE (scm_struct_vtable_name, "struct-vtable-name", 1, 0, 0,
 735             (SCM vtable),
 736             "Return the name of the vtable @var{vtable}.")
 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 SCM_DEFINE (scm_set_struct_vtable_name_x, "set-struct-vtable-name!", 2, 0, 0,
 745             (SCM vtable, SCM name),
 746             "Set the name of the vtable @var{vtable} to @var{name}.")
 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_is_true (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_is_true (name))
 771         scm_display (name, port);
 772       else
 773         scm_puts ("struct", port);
 774       scm_putc (' ', port);
 775       scm_intprint (SCM_UNPACK (vtable), 16, port);
 776       scm_putc (':', port);
 777       scm_intprint (SCM_UNPACK (exp), 16, port);
 778       scm_putc ('>', port);
 779     }
 780 }
 781
 782 void
 783 scm_struct_prehistory ()
 784 {
 785   scm_i_structs_to_free = SCM_EOL;
 786   scm_c_hook_add (&scm_before_sweep_c_hook, scm_struct_gc_init, 0, 0);
 787   /* With the new lazy sweep GC, the point at which the entire heap is
 788      swept is just before the mark phase. */
 789   scm_c_hook_add (&scm_before_mark_c_hook, scm_free_structs, 0, 0);
 790 }
 791
 792 void
 793 scm_init_struct ()
 794 {
 795   scm_struct_table
 796     = scm_permanent_object (scm_make_weak_key_hash_table (SCM_MAKINUM (31)));
 797   required_vtable_fields = scm_makfrom0str ("prsrpw");
 798   scm_permanent_object (required_vtable_fields);
 799   scm_c_define ("vtable-index-layout", SCM_MAKINUM (scm_vtable_index_layout));
 800   scm_c_define ("vtable-index-vtable", SCM_MAKINUM (scm_vtable_index_vtable));
 801   scm_c_define ("vtable-index-printer",
 802                 SCM_MAKINUM (scm_vtable_index_printer));
 803   scm_c_define ("vtable-offset-user", SCM_MAKINUM (scm_vtable_offset_user));
 804 #include "libguile/struct.x"
 805 }
 806
 807 /*
 808   Local Variables:
 809   c-file-style: "gnu"
 810   End:
 811 */