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