libguile/struct.c

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