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
  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 void
 137 scm_struct_init (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 = 0;
 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, "scm_struct_init");
 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, "scm_struct_init");
 192               inits = SCM_CDR (inits);
 193             }
 194           break;
 195
 196         case 'p':
 197           if ((prot != 'r' && prot != 'w') || inits == SCM_EOL)
 198             *mem = SCM_BOOL_F;
 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), "scm_struct_init");
 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 SCM *
 314 scm_alloc_struct (int n_words, int n_extra, char *who)
 315 {
 316   int size = sizeof (SCM) * (n_words + n_extra) + 7;
 317   SCM *block = (SCM *) scm_must_malloc (size, who);
 318
 319   /* Adjust the pointer to hide the extra words.  */
 320   SCM *p = block + n_extra;
 321
 322   /* Adjust it even further so it's aligned on an eight-byte boundary.  */
 323   p = (SCM *) (((SCM) p + 7) & ~7);
 324
 325   /* Initialize a few fields as described above.  */
 326   p[scm_struct_i_ptr] = (SCM) block;
 327   p[scm_struct_i_n_words] = (SCM) (n_words + n_extra);
 328   p[scm_struct_i_tag] = struct_num++;
 329
 330   return p;
 331 }
 332
 333
 334 SCM_PROC (s_make_struct, "make-struct", 2, 0, 1, scm_make_struct);
 335
 336 SCM
 337 scm_make_struct (vtable, tail_array_size, init)
 338      SCM vtable;
 339      SCM tail_array_size;
 340      SCM init;
 341 {
 342   SCM layout;
 343   int basic_size;
 344   int tail_elts;
 345   SCM * data;
 346   SCM handle;
 347
 348   SCM_ASSERT ((SCM_BOOL_F != scm_struct_vtable_p (vtable)),
 349               vtable, SCM_ARG1, s_make_struct);
 350   SCM_ASSERT (SCM_INUMP (tail_array_size), tail_array_size, SCM_ARG2,
 351               s_make_struct);
 352
 353   layout = SCM_STRUCT_DATA (vtable)[scm_vtable_index_layout];
 354   basic_size = SCM_LENGTH (layout) / 2;
 355   tail_elts = SCM_INUM (tail_array_size);
 356   SCM_NEWCELL (handle);
 357   SCM_DEFER_INTS;
 358   if (SCM_STRUCT_DATA (vtable)[scm_struct_i_flags] & SCM_STRUCTF_ENTITY)
 359     {
 360       data = scm_alloc_struct (basic_size + tail_elts,
 361                                scm_struct_n_extra_words + 4,
 362                                "make-struct");
 363       data[scm_struct_i_proc + 0] = SCM_BOOL_F;
 364       data[scm_struct_i_proc + 1] = SCM_BOOL_F;
 365       data[scm_struct_i_proc + 2] = SCM_BOOL_F;
 366       data[scm_struct_i_proc + 3] = SCM_BOOL_F;
 367     }
 368   else
 369     data = scm_alloc_struct (basic_size + tail_elts,
 370                              scm_struct_n_extra_words,
 371                              "make-struct");
 372   SCM_SETCDR (handle, data);
 373   SCM_SETCAR (handle, ((SCM)SCM_STRUCT_DATA (vtable)) + scm_tc3_cons_gloc);
 374   scm_struct_init (handle, tail_elts, init);
 375   SCM_ALLOW_INTS;
 376   return handle;
 377 }
 378
 379
 380
 381 SCM_PROC (s_make_vtable_vtable, "make-vtable-vtable", 2, 0, 1, scm_make_vtable_vtable);
 382
 383 SCM
 384 scm_make_vtable_vtable (extra_fields, tail_array_size, init)
 385      SCM extra_fields;
 386      SCM tail_array_size;
 387      SCM init;
 388 {
 389   SCM fields;
 390   SCM layout;
 391   int basic_size;
 392   int tail_elts;
 393   SCM * data;
 394   SCM handle;
 395
 396   SCM_ASSERT (SCM_NIMP (extra_fields) && SCM_ROSTRINGP (extra_fields),
 397               extra_fields, SCM_ARG1, s_make_vtable_vtable);
 398   SCM_ASSERT (SCM_INUMP (tail_array_size), tail_array_size, SCM_ARG2,
 399               s_make_vtable_vtable);
 400
 401   fields = scm_string_append (scm_listify (required_vtable_fields,
 402                                            extra_fields,
 403                                            SCM_UNDEFINED));
 404   layout = scm_make_struct_layout (fields);
 405   basic_size = SCM_LENGTH (layout) / 2;
 406   tail_elts = SCM_INUM (tail_array_size);
 407   SCM_NEWCELL (handle);
 408   SCM_DEFER_INTS;
 409   data = scm_alloc_struct (basic_size + tail_elts,
 410                            scm_struct_n_extra_words,
 411                            "make-vtable-vtable");
 412   SCM_SETCDR (handle, data);
 413   SCM_SETCAR (handle, ((SCM)data) + scm_tc3_cons_gloc);
 414   SCM_STRUCT_LAYOUT (handle) = layout;
 415   scm_struct_init (handle, tail_elts, scm_cons (layout, init));
 416   SCM_ALLOW_INTS;
 417   return handle;
 418 }
 419
 420 \f
 421
 422
 423 SCM_PROC (s_struct_ref, "struct-ref", 2, 0, 0, scm_struct_ref);
 424
 425 SCM
 426 scm_struct_ref (handle, pos)
 427      SCM handle;
 428      SCM pos;
 429 {
 430   SCM answer = SCM_UNDEFINED;
 431   SCM * data;
 432   SCM layout;
 433   int p;
 434   int n_fields;
 435   unsigned char * fields_desc;
 436   unsigned char field_type = 0;
 437
 438
 439   SCM_ASSERT (SCM_NIMP (handle) && SCM_STRUCTP (handle), handle,
 440               SCM_ARG1, s_struct_ref);
 441   SCM_ASSERT (SCM_INUMP (pos), pos, SCM_ARG2, s_struct_ref);
 442
 443   layout = SCM_STRUCT_LAYOUT (handle);
 444   data = SCM_STRUCT_DATA (handle);
 445   p = SCM_INUM (pos);
 446
 447   fields_desc = (unsigned char *)SCM_CHARS (layout);
 448   n_fields = data[scm_struct_i_n_words] - scm_struct_n_extra_words;
 449
 450   SCM_ASSERT (p < n_fields, pos, SCM_OUTOFRANGE, s_struct_ref);
 451
 452   if (p * 2 < SCM_LENGTH (layout))
 453     {
 454       unsigned char ref;
 455       field_type = fields_desc[p * 2];
 456       ref = fields_desc[p * 2 + 1];
 457       if ((ref != 'r') && (ref != 'w'))
 458         {
 459           if ((ref == 'R') || (ref == 'W'))
 460             field_type = 'u';
 461           else
 462             SCM_ASSERT (0, pos, "ref denied", s_struct_ref);
 463         }
 464     }
 465   else if (fields_desc[SCM_LENGTH (layout) - 1] != 'O')
 466     field_type = fields_desc[SCM_LENGTH (layout) - 2];
 467   else
 468     {
 469       SCM_ASSERT (0, pos, "ref denied", s_struct_ref);
 470       abort ();
 471     }
 472
 473   switch (field_type)
 474     {
 475     case 'u':
 476       answer = scm_ulong2num (data[p]);
 477       break;
 478
 479 #if 0
 480     case 'i':
 481       answer = scm_long2num (data[p]);
 482       break;
 483
 484     case 'd':
 485       answer = scm_makdbl (*((double *)&(data[p])), 0.0);
 486       break;
 487 #endif
 488
 489     case 's':
 490     case 'p':
 491       answer = data[p];
 492       break;
 493
 494
 495     default:
 496       SCM_ASSERT (0, SCM_MAKICHR (field_type), "unrecognized field type", s_struct_ref);
 497       break;
 498     }
 499
 500   return answer;
 501 }
 502
 503
 504 SCM_PROC (s_struct_set_x, "struct-set!", 3, 0, 0, scm_struct_set_x);
 505
 506 SCM
 507 scm_struct_set_x (handle, pos, val)
 508      SCM handle;
 509      SCM pos;
 510      SCM val;
 511 {
 512   SCM * data;
 513   SCM layout;
 514   int p;
 515   int n_fields;
 516   unsigned char * fields_desc;
 517   unsigned char field_type = 0;
 518
 519
 520
 521   SCM_ASSERT (SCM_NIMP (handle) && SCM_STRUCTP (handle), handle,
 522               SCM_ARG1, s_struct_ref);
 523   SCM_ASSERT (SCM_INUMP (pos), pos, SCM_ARG2, s_struct_ref);
 524
 525   layout = SCM_STRUCT_LAYOUT (handle);
 526   data = SCM_STRUCT_DATA (handle);
 527   p = SCM_INUM (pos);
 528
 529   fields_desc = (unsigned char *)SCM_CHARS (layout);
 530   n_fields = data[scm_struct_i_n_words] - scm_struct_n_extra_words;
 531
 532   SCM_ASSERT (p < n_fields, pos, SCM_OUTOFRANGE, s_struct_set_x);
 533
 534   if (p * 2 < SCM_LENGTH (layout))
 535     {
 536       unsigned char set_x;
 537       field_type = fields_desc[p * 2];
 538       set_x = fields_desc [p * 2 + 1];
 539       if (set_x != 'w')
 540         SCM_ASSERT (0, pos, "set_x denied", s_struct_set_x);
 541     }
 542   else if (fields_desc[SCM_LENGTH (layout) - 1] == 'W')
 543     field_type = fields_desc[SCM_LENGTH (layout) - 2];
 544   else
 545     {
 546       SCM_ASSERT (0, pos, "set_x denied", s_struct_ref);
 547       abort ();
 548     }
 549
 550   switch (field_type)
 551     {
 552     case 'u':
 553       data[p] = (SCM)scm_num2ulong (val, (char *)SCM_ARG3, s_struct_set_x);
 554       break;
 555
 556 #if 0
 557     case 'i':
 558       data[p] = scm_num2long (val, (char *)SCM_ARG3, s_struct_set_x);
 559       break;
 560
 561     case 'd':
 562       *((double *)&(data[p])) = scm_num2dbl (val, (char *)SCM_ARG3);
 563       break;
 564 #endif
 565
 566     case 'p':
 567       data[p] = val;
 568       break;
 569
 570     case 's':
 571       SCM_ASSERT (0, SCM_MAKICHR (field_type), "self fields immutable", s_struct_set_x);
 572       break;
 573
 574     default:
 575       SCM_ASSERT (0, SCM_MAKICHR (field_type), "unrecognized field type", s_struct_set_x);
 576       break;
 577     }
 578
 579   return val;
 580 }
 581
 582
 583 SCM_PROC (s_struct_vtable, "struct-vtable", 1, 0, 0, scm_struct_vtable);
 584
 585 SCM
 586 scm_struct_vtable (handle)
 587      SCM handle;
 588 {
 589   SCM_ASSERT (SCM_NIMP (handle) && SCM_STRUCTP (handle), handle,
 590               SCM_ARG1, s_struct_vtable);
 591   return SCM_STRUCT_VTABLE (handle);
 592 }
 593
 594
 595 SCM_PROC (s_struct_vtable_tag, "struct-vtable-tag", 1, 0, 0, scm_struct_vtable_tag);
 596
 597 SCM
 598 scm_struct_vtable_tag (handle)
 599      SCM handle;
 600 {
 601   SCM_ASSERT (SCM_NIMP (handle) && (SCM_BOOL_F != scm_struct_vtable_p (handle)),
 602               handle, SCM_ARG1, s_struct_vtable_tag);
 603   return scm_long2num (SCM_STRUCT_DATA (handle)[-1]);
 604 }
 605
 606
 607 \f
 608
 609 void
 610 scm_print_struct (exp, port, pstate)
 611      SCM exp;
 612      SCM port;
 613      scm_print_state *pstate;
 614 {
 615   if (SCM_NFALSEP (scm_procedure_p (SCM_STRUCT_PRINTER (exp))))
 616     scm_printer_apply (SCM_STRUCT_PRINTER (exp), exp, port, pstate);
 617   else
 618     {
 619       scm_lfwrite ("#<struct ", sizeof ("#<struct ") - 1, port);
 620       scm_intprint (SCM_STRUCT_VTABLE (exp), 16, port);
 621       scm_putc (':', port);
 622       scm_intprint (exp, 16, port);
 623       scm_putc ('>', port);
 624     }
 625 }
 626
 627 void
 628 scm_init_struct ()
 629 {
 630   required_vtable_fields = SCM_CAR (scm_intern_obarray ("pruosrpw", sizeof ("pruosrpw") - 1, SCM_BOOL_F));
 631   scm_permanent_object (required_vtable_fields);
 632   scm_sysintern ("vtable-index-layout", SCM_MAKINUM (scm_vtable_index_layout));
 633   scm_sysintern ("vtable-index-vtable", SCM_MAKINUM (scm_vtable_index_vtable));
 634   scm_sysintern ("vtable-index-printer", SCM_MAKINUM (scm_vtable_index_printer));
 635   scm_sysintern ("vtable-offset-user", SCM_MAKINUM (scm_vtable_offset_user));
 636 #include "struct.x"
 637 }