libguile/struct.c

   1 /*      Copyright (C) 1996 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, 675 Mass Ave, Cambridge, MA 02139, USA.
  16  *
  17  * As a special exception, the Free Software Foundation gives permission
  18  * for additional uses of the text contained in its release of GUILE.
  19  *
  20  * The exception is that, if you link the GUILE library with other files
  21  * to produce an executable, this does not by itself cause the
  22  * resulting executable to be covered by the GNU General Public License.
  23  * Your use of that executable is in no way restricted on account of
  24  * linking the GUILE library code into it.
  25  *
  26  * This exception does not however invalidate any other reasons why
  27  * the executable file might be covered by the GNU General Public License.
  28  *
  29  * This exception applies only to the code released by the
  30  * Free Software Foundation under the name GUILE.  If you copy
  31  * code from other Free Software Foundation releases into a copy of
  32  * GUILE, as the General Public License permits, the exception does
  33  * not apply to the code that you add in this way.  To avoid misleading
  34  * anyone as to the status of such modified files, you must delete
  35  * this exception notice from them.
  36  *
  37  * If you write modifications of your own for GUILE, it is your choice
  38  * whether to permit this exception to apply to your modifications.
  39  * If you do not wish that, delete this exception notice.
  40  */
  41 \f
  42
  43 #include <stdio.h>
  44 #include "_scm.h"
  45 #include "chars.h"
  46
  47 #include "struct.h"
  48
  49 #ifdef HAVE_STRING_H
  50 #include <string.h>
  51 #endif
  52
  53 \f
  54
  55 static SCM required_vtable_fields = SCM_BOOL_F;
  56 static int struct_num = 0;
  57
  58 \f
  59 SCM_PROC (s_struct_make_layout, "make-struct-layout", 1, 0, 0, scm_make_struct_layout);
  60
  61 SCM
  62 scm_make_struct_layout (fields)
  63      SCM fields;
  64 {
  65   SCM new_sym;
  66   SCM_ASSERT (SCM_NIMP (fields) && SCM_ROSTRINGP (fields),
  67               fields, SCM_ARG1, s_struct_make_layout);
  68
  69   {
  70     char * field_desc;
  71     int len;
  72     int x;
  73
  74     len = SCM_ROLENGTH (fields);
  75     field_desc = SCM_ROCHARS (fields);
  76     SCM_ASSERT (!(len & 1), fields, "odd length field specification", s_struct_make_layout);
  77
  78     for (x = 0; x < len; x += 2)
  79       {
  80         switch (field_desc[x])
  81           {
  82           case 'u':
  83           case 'p':
  84 #if 0
  85           case 'i':
  86           case 'd':
  87 #endif
  88           case 's':
  89             break;
  90           default:
  91             SCM_ASSERT (0, SCM_MAKICHR (field_desc[x]) , "unrecognized field type", s_struct_make_layout);
  92           }
  93
  94         switch (field_desc[x + 1])
  95           {
  96           case 'w':
  97             SCM_ASSERT (field_desc[x] != 's', SCM_MAKICHR (field_desc[x + 1]),
  98                         "self fields not writable", s_struct_make_layout);
  99
 100           case 'r':
 101           case 'o':
 102             break;
 103           case 'R':
 104           case 'W':
 105           case 'O':
 106             SCM_ASSERT (field_desc[x] != 's', SCM_MAKICHR (field_desc[x + 1]),
 107                         "self fields not allowed in tail array",
 108                         s_struct_make_layout);
 109             SCM_ASSERT (x == len - 2, SCM_MAKICHR (field_desc[x + 1]),
 110                         "tail array field must be last field in layout",
 111                         s_struct_make_layout);
 112             break;
 113           default:
 114             SCM_ASSERT (0, SCM_MAKICHR (field_desc[x]) , "unrecognized ref specification", s_struct_make_layout);
 115           }
 116 #if 0
 117         if (field_desc[x] == 'd')
 118           {
 119             SCM_ASSERT (field_desc[x + 2] == '-', SCM_MAKINUM (x / 2), "missing dash field", s_struct_make_layout);
 120             x += 2;
 121             goto recheck_ref;
 122           }
 123 #endif
 124       }
 125     new_sym = SCM_CAR (scm_intern_obarray (field_desc, len, SCM_BOOL_F));
 126   }
 127   return scm_return_first (new_sym, fields);
 128 }
 129
 130 \f
 131
 132
 133
 134 static void init_struct SCM_P ((SCM handle, int tail_elts, SCM inits));
 135
 136 static void
 137 init_struct (handle, tail_elts, inits)
 138      SCM handle;
 139      int tail_elts;
 140      SCM inits;
 141 {
 142   SCM layout;
 143   SCM * data;
 144   unsigned char * fields_desc;
 145   unsigned char prot;
 146   int n_fields;
 147   SCM * mem;
 148   int tailp = 0;
 149
 150   layout = SCM_STRUCT_LAYOUT (handle);
 151   data = SCM_STRUCT_DATA (handle);
 152   fields_desc = (unsigned char *) SCM_CHARS (layout) - 2;
 153   n_fields = SCM_LENGTH (layout) / 2;
 154   mem = SCM_STRUCT_DATA (handle);
 155   while (n_fields)
 156     {
 157       if (!tailp)
 158         {
 159           fields_desc += 2;
 160           prot = fields_desc[1];
 161           if (SCM_LAYOUT_TAILP (prot))
 162             {
 163               tailp = 1;
 164               prot = prot == 'R' ? 'r' : prot == 'W' ? 'w' : 'o';
 165               *mem++ = tail_elts;
 166               n_fields += tail_elts - 1;
 167               if (n_fields == 0)
 168                 break;
 169             }
 170         }
 171
 172       switch (*fields_desc)
 173         {
 174 #if 0
 175         case 'i':
 176           if ((prot != 'r' && prot != 'w') || inits == SCM_EOL)
 177             *mem = 0;
 178           else
 179             {
 180               *mem = scm_num2long (SCM_CAR (inits), SCM_ARGn, "init_struct");
 181               inits = SCM_CDR (inits);
 182             }
 183           break;
 184 #endif
 185
 186         case 'u':
 187           if ((prot != 'r' && prot != 'w') || inits == SCM_EOL)
 188             *mem = 0;
 189           else
 190             {
 191               *mem = scm_num2ulong (SCM_CAR (inits), SCM_ARGn, "init_struct");
 192               inits = SCM_CDR (inits);
 193             }
 194           break;
 195
 196         case 'p':
 197           if ((prot != 'r' && prot != 'w') || inits == SCM_EOL)
 198             *mem = SCM_EOL;
 199           else
 200             {
 201               *mem = SCM_CAR (inits);
 202               inits = SCM_CDR (inits);
 203             }
 204
 205           break;
 206
 207 #if 0
 208         case 'd':
 209           if ((prot != 'r' && prot != 'w') || inits == SCM_EOL)
 210             *((double *)mem) = 0.0;
 211           else
 212             {
 213               *mem = scm_num2dbl (SCM_CAR (inits), "init_struct");
 214               inits = SCM_CDR (inits);
 215             }
 216           fields_desc += 2;
 217           break;
 218 #endif
 219
 220         case 's':
 221           *mem = handle;
 222           break;
 223         }
 224
 225       n_fields--;
 226       mem++;
 227     }
 228 }
 229
 230
 231 SCM_PROC (s_struct_p, "struct?", 1, 0, 0, scm_struct_p);
 232
 233 SCM
 234 scm_struct_p (x)
 235      SCM x;
 236 {
 237   return ((SCM_NIMP (x) && SCM_STRUCTP (x))
 238           ? SCM_BOOL_T
 239           : SCM_BOOL_F);
 240 }
 241
 242 SCM_PROC (s_struct_vtable_p, "struct-vtable?", 1, 0, 0, scm_struct_vtable_p);
 243
 244 SCM
 245 scm_struct_vtable_p (x)
 246      SCM x;
 247 {
 248   SCM layout;
 249   SCM * mem;
 250
 251   if (SCM_IMP (x))
 252     return SCM_BOOL_F;
 253
 254   if (!SCM_STRUCTP (x))
 255     return SCM_BOOL_F;
 256
 257   layout = SCM_STRUCT_LAYOUT (x);
 258
 259   if (SCM_LENGTH (layout) < SCM_LENGTH (required_vtable_fields))
 260     return SCM_BOOL_F;
 261
 262   if (strncmp (SCM_CHARS (layout), SCM_CHARS (required_vtable_fields),
 263                SCM_LENGTH (required_vtable_fields)))
 264     return SCM_BOOL_F;
 265
 266   mem = SCM_STRUCT_DATA (x);
 267
 268   if (mem[1] != 0)
 269     return SCM_BOOL_F;
 270
 271   if (SCM_IMP (mem[0]))
 272     return SCM_BOOL_F;
 273
 274   return (SCM_SYMBOLP (mem[0])
 275           ? SCM_BOOL_T
 276           : SCM_BOOL_F);
 277 }
 278
 279
 280 /* All struct data must be allocated at an address whose bottom three
 281    bits are zero.  This is because the tag for a struct lives in the
 282    bottom three bits of the struct's car, and the upper bits point to
 283    the data of its vtable, which is a struct itself.  Thus, if the
 284    address of that data doesn't end in three zeros, tagging it will
 285    destroy the pointer.
 286
 287    This function allocates a block of memory, and returns a pointer at
 288    least scm_struct_n_extra_words words into the block.  Furthermore,
 289    it guarantees that that pointer's least three significant bits are
 290    all zero.
 291
 292    The argument n_words should be the number of words that should
 293    appear after the returned address.  (That is, it shouldn't include
 294    scm_struct_n_extra_words.)
 295
 296    This function initializes the following fields of the struct:
 297
 298      scm_struct_i_ptr --- the actual stort of the block of memory; the
 299          address you should pass to 'free' to dispose of the block.
 300          This field allows us to both guarantee that the returned
 301          address is divisible by eight, and allow the GC to free the
 302          block.
 303
 304      scm_struct_i_n_words --- the number of words allocated to the
 305          block, including the extra fields.  This is used by the GC.
 306
 307      scm_struct_i_tag --- a unique tag assigned to this struct,
 308          allocated according to struct_num.
 309
 310      Ugh.  */
 311
 312
 313 static SCM *alloc_struct SCM_P ((int n_words, char *who));
 314
 315 static SCM *
 316 alloc_struct (n_words, who)
 317      int n_words;
 318      char *who;
 319 {
 320   int size = sizeof (SCM) * (n_words + scm_struct_n_extra_words) + 7;
 321   SCM *block = (SCM *) scm_must_malloc (size, who);
 322
 323   /* Adjust the pointer to hide the extra words.  */
 324   SCM *p = block + scm_struct_n_extra_words;
 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.  */
 330   p[scm_struct_i_ptr] = (SCM) block;
 331   p[scm_struct_i_n_words] = (SCM) (scm_struct_n_extra_words + n_words);
 332   p[scm_struct_i_tag] = struct_num++;
 333
 334   return p;
 335 }
 336
 337
 338 SCM_PROC (s_make_struct, "make-struct", 2, 0, 1, scm_make_struct);
 339
 340 SCM
 341 scm_make_struct (vtable, tail_array_size, init)
 342      SCM vtable;
 343      SCM tail_array_size;
 344      SCM init;
 345 {
 346   SCM layout;
 347   int basic_size;
 348   int tail_elts;
 349   SCM * data;
 350   SCM handle;
 351
 352   SCM_ASSERT ((SCM_BOOL_F != scm_struct_vtable_p (vtable)),
 353               vtable, SCM_ARG1, s_make_struct);
 354   SCM_ASSERT (SCM_INUMP (tail_array_size), tail_array_size, SCM_ARG2,
 355               s_make_struct);
 356
 357   layout = SCM_STRUCT_DATA (vtable)[scm_struct_i_layout];
 358   basic_size = SCM_LENGTH (layout) / 2;
 359   tail_elts = SCM_INUM (tail_array_size);
 360   SCM_NEWCELL (handle);
 361   SCM_DEFER_INTS;
 362   data = alloc_struct (basic_size + tail_elts, "make-struct");
 363   SCM_SETCDR (handle, data);
 364   SCM_SETCAR (handle, ((SCM)SCM_STRUCT_DATA (vtable)) + scm_tc3_cons_gloc);
 365   init_struct (handle, tail_elts, init);
 366   SCM_ALLOW_INTS;
 367   return handle;
 368 }
 369
 370
 371
 372 SCM_PROC (s_make_vtable_vtable, "make-vtable-vtable", 2, 0, 1, scm_make_vtable_vtable);
 373
 374 SCM
 375 scm_make_vtable_vtable (extra_fields, tail_array_size, init)
 376      SCM extra_fields;
 377      SCM tail_array_size;
 378      SCM init;
 379 {
 380   SCM fields;
 381   SCM layout;
 382   int basic_size;
 383   int tail_elts;
 384   SCM * data;
 385   SCM handle;
 386
 387   SCM_ASSERT (SCM_NIMP (extra_fields) && SCM_ROSTRINGP (extra_fields),
 388               extra_fields, SCM_ARG1, s_make_vtable_vtable);
 389   SCM_ASSERT (SCM_INUMP (tail_array_size), tail_array_size, SCM_ARG2,
 390               s_make_vtable_vtable);
 391
 392   fields = scm_string_append (scm_listify (required_vtable_fields,
 393                                            extra_fields,
 394                                            SCM_UNDEFINED));
 395   layout = scm_make_struct_layout (fields);
 396   basic_size = SCM_LENGTH (layout) / 2;
 397   tail_elts = SCM_INUM (tail_array_size);
 398   SCM_NEWCELL (handle);
 399   SCM_DEFER_INTS;
 400   data = alloc_struct (basic_size + tail_elts, "make-vtable-vtable");
 401   SCM_SETCDR (handle, data);
 402   SCM_SETCAR (handle, ((SCM)data) + scm_tc3_cons_gloc);
 403   SCM_STRUCT_LAYOUT (handle) = layout;
 404   init_struct (handle, tail_elts, scm_cons (layout, init));
 405   SCM_ALLOW_INTS;
 406   return handle;
 407 }
 408
 409 \f
 410
 411
 412 SCM_PROC (s_struct_ref, "struct-ref", 2, 0, 0, scm_struct_ref);
 413
 414 SCM
 415 scm_struct_ref (handle, pos)
 416      SCM handle;
 417      SCM pos;
 418 {
 419   SCM answer = SCM_UNDEFINED;
 420   SCM * data;
 421   SCM layout;
 422   int p;
 423   int n_fields;
 424   unsigned char * fields_desc;
 425   unsigned char field_type;
 426
 427
 428   SCM_ASSERT (SCM_NIMP (handle) && SCM_STRUCTP (handle), handle,
 429               SCM_ARG1, s_struct_ref);
 430   SCM_ASSERT (SCM_INUMP (pos), pos, SCM_ARG2, s_struct_ref);
 431
 432   layout = SCM_STRUCT_LAYOUT (handle);
 433   data = SCM_STRUCT_DATA (handle);
 434   p = SCM_INUM (pos);
 435
 436   fields_desc = (unsigned char *)SCM_CHARS (layout);
 437   n_fields = data[- scm_struct_n_extra_words] - scm_struct_n_extra_words;
 438
 439   SCM_ASSERT (p < n_fields, pos, SCM_OUTOFRANGE, s_struct_ref);
 440
 441   if (p * 2 < SCM_LENGTH (layout))
 442     {
 443       unsigned char ref;
 444       field_type = fields_desc[p * 2];
 445       ref = fields_desc[p * 2 + 1];
 446       if ((ref != 'r') && (ref != 'w'))
 447         {
 448           if ((ref == 'R') || (ref == 'W'))
 449             field_type = 'u';
 450           else
 451             SCM_ASSERT (0, pos, "ref denied", s_struct_ref);
 452         }
 453     }
 454   else if (fields_desc[SCM_LENGTH (layout) - 1] != 'O')
 455     field_type = fields_desc[SCM_LENGTH (layout) - 2];
 456   else
 457     {
 458       SCM_ASSERT (0, pos, "ref denied", s_struct_ref);
 459     }
 460
 461   switch (field_type)
 462     {
 463     case 'u':
 464       answer = scm_ulong2num (data[p]);
 465       break;
 466
 467 #if 0
 468     case 'i':
 469       answer = scm_long2num (data[p]);
 470       break;
 471
 472     case 'd':
 473       answer = scm_makdbl (*((double *)&(data[p])), 0.0);
 474       break;
 475 #endif
 476
 477     case 's':
 478     case 'p':
 479       answer = data[p];
 480       break;
 481
 482
 483     default:
 484       SCM_ASSERT (0, SCM_MAKICHR (field_type), "unrecognized field type", s_struct_ref);
 485       break;
 486     }
 487
 488   return answer;
 489 }
 490
 491
 492 SCM_PROC (s_struct_set_x, "struct-set!", 3, 0, 0, scm_struct_set_x);
 493
 494 SCM
 495 scm_struct_set_x (handle, pos, val)
 496      SCM handle;
 497      SCM pos;
 498      SCM val;
 499 {
 500   SCM * data;
 501   SCM layout;
 502   int p;
 503   int n_fields;
 504   unsigned char * fields_desc;
 505   unsigned char field_type;
 506
 507
 508
 509   SCM_ASSERT (SCM_NIMP (handle) && SCM_STRUCTP (handle), handle,
 510               SCM_ARG1, s_struct_ref);
 511   SCM_ASSERT (SCM_INUMP (pos), pos, SCM_ARG2, s_struct_ref);
 512
 513   layout = SCM_STRUCT_LAYOUT (handle);
 514   data = SCM_STRUCT_DATA (handle);
 515   p = SCM_INUM (pos);
 516
 517   fields_desc = (unsigned char *)SCM_CHARS (layout);
 518   n_fields = data[- scm_struct_n_extra_words] - scm_struct_n_extra_words;
 519
 520   SCM_ASSERT (p < n_fields, pos, SCM_OUTOFRANGE, s_struct_set_x);
 521
 522   if (p * 2 < SCM_LENGTH (layout))
 523     {
 524       unsigned char set_x;
 525       field_type = fields_desc[p * 2];
 526       set_x = fields_desc [p * 2 + 1];
 527       if (set_x != 'w')
 528         SCM_ASSERT (0, pos, "set_x denied", s_struct_set_x);
 529     }
 530   else if (fields_desc[SCM_LENGTH (layout) - 1] == 'W')
 531     field_type = fields_desc[SCM_LENGTH (layout) - 2];
 532   else
 533     {
 534       SCM_ASSERT (0, pos, "set_x denied", s_struct_ref);
 535     }
 536
 537   switch (field_type)
 538     {
 539     case 'u':
 540       data[p] = (SCM)scm_num2ulong (val, (char *)SCM_ARG3, s_struct_set_x);
 541       break;
 542
 543 #if 0
 544     case 'i':
 545       data[p] = scm_num2long (val, (char *)SCM_ARG3, s_struct_set_x);
 546       break;
 547
 548     case 'd':
 549       *((double *)&(data[p])) = scm_num2dbl (val, (char *)SCM_ARG3);
 550       break;
 551 #endif
 552
 553     case 'p':
 554       data[p] = val;
 555       break;
 556
 557     case 's':
 558       SCM_ASSERT (0, SCM_MAKICHR (field_type), "self fields immutable", s_struct_set_x);
 559       break;
 560
 561     default:
 562       SCM_ASSERT (0, SCM_MAKICHR (field_type), "unrecognized field type", s_struct_set_x);
 563       break;
 564     }
 565
 566   return val;
 567 }
 568
 569
 570 SCM_PROC (s_struct_vtable, "struct-vtable", 1, 0, 0, scm_struct_vtable);
 571
 572 SCM
 573 scm_struct_vtable (handle)
 574      SCM handle;
 575 {
 576   SCM_ASSERT (SCM_NIMP (handle) && SCM_STRUCTP (handle), handle,
 577               SCM_ARG1, s_struct_vtable);
 578   return SCM_STRUCT_VTABLE (handle);
 579 }
 580
 581
 582 SCM_PROC (s_struct_vtable_tag, "struct-vtable-tag", 1, 0, 0, scm_struct_vtable_tag);
 583
 584 SCM
 585 scm_struct_vtable_tag (handle)
 586      SCM handle;
 587 {
 588   SCM_ASSERT (SCM_NIMP (handle) && (SCM_BOOL_F != scm_struct_vtable_p (handle)),
 589               handle, SCM_ARG1, s_struct_vtable_tag);
 590   return scm_long2num (SCM_STRUCT_DATA (handle)[-1]);
 591 }
 592
 593
 594 \f
 595
 596
 597 void
 598 scm_init_struct ()
 599 {
 600   required_vtable_fields = SCM_CAR (scm_intern_obarray ("pruosr", sizeof ("pruosr") - 1, SCM_BOOL_F));
 601   scm_permanent_object (required_vtable_fields);
 602   scm_sysintern ("struct-vtable-offset", SCM_MAKINUM (scm_struct_i_vtable_offset));
 603 #include "struct.x"
 604 }
 605