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
  46 #ifdef HAVE_STRING_H
  47 #include <string.h>
  48 #endif
  49
  50 \f
  51
  52 static SCM required_vtable_fields = SCM_BOOL_F;
  53 static int struct_num = 0;
  54
  55 \f
  56 SCM_PROC (s_struct_make_layout, "make-struct-layout", 1, 0, 0, scm_make_struct_layout);
  57 #ifdef __STDC__
  58 SCM
  59 scm_make_struct_layout (SCM fields)
  60 #else
  61 SCM
  62 scm_make_struct_layout (fields)
  63      SCM fields;
  64 #endif
  65 {
  66   SCM new_sym;
  67   SCM_ASSERT (SCM_NIMP (fields) && SCM_ROSTRINGP (fields),
  68               fields, SCM_ARG1, s_struct_make_layout);
  69
  70   {
  71     char * field_desc;
  72     int len;
  73     int x;
  74
  75     len = SCM_ROLENGTH (fields);
  76     field_desc = SCM_ROCHARS (fields);
  77     SCM_ASSERT (!(len & 1), fields, "odd length field specification", s_struct_make_layout);
  78
  79     for (x = 0; x < len; x += 2)
  80       {
  81         switch (field_desc[x])
  82           {
  83           case 'u':
  84           case 'p':
  85 #if 0
  86           case 'i':
  87           case 'd':
  88 #endif
  89           case 's':
  90             break;
  91           default:
  92             SCM_ASSERT (0, SCM_MAKICHR (field_desc[x]) , "unrecognized field type", s_struct_make_layout);
  93           }
  94
  95         switch (field_desc[x + 1])
  96           {
  97           case 'w':
  98             SCM_ASSERT ((field_desc[x] != 's'), SCM_MAKICHR (field_desc[x + 1]),
  99                         "self fields not writable", s_struct_make_layout);
 100
 101           case 'r':
 102           case 'o':
 103             break;
 104           default:
 105             SCM_ASSERT (0, SCM_MAKICHR (field_desc[x]) , "unrecognized ref specification", s_struct_make_layout);
 106           }
 107 #if 0
 108         if (field_desc[x] == 'd')
 109           {
 110             SCM_ASSERT (field_desc[x + 2] == '-', SCM_MAKINUM (x / 2), "missing dash field", s_struct_make_layout);
 111             x += 2;
 112             goto recheck_ref;
 113           }
 114 #endif
 115       }
 116     new_sym = SCM_CAR (scm_intern_obarray (field_desc, len, SCM_BOOL_F));
 117   }
 118   return scm_return_first (new_sym, fields);
 119 }
 120
 121 \f
 122
 123
 124 #ifdef __STDC__
 125 static void
 126 init_struct (SCM handle, SCM tail_elts, SCM inits)
 127 #else
 128 static void
 129 init_struct (handle, tail_elts, inits)
 130      SCM handle;
 131      SCM tail_elts;
 132      SCM inits;
 133 #endif
 134 {
 135   SCM layout;
 136   SCM * data;
 137   unsigned char * fields_desc;
 138   int n_fields;
 139   SCM * mem;
 140
 141   layout = SCM_STRUCT_LAYOUT (handle);
 142   data = SCM_STRUCT_DATA (handle);
 143   fields_desc = (unsigned char *)SCM_CHARS (layout);
 144   n_fields = SCM_LENGTH (layout) / 2;
 145   mem = SCM_STRUCT_DATA (handle);
 146   while (n_fields)
 147     {
 148       switch (*fields_desc)
 149         {
 150 #if 0
 151         case 'i':
 152           if (   ((fields_desc[1] != 'r') && (fields_desc[1] != 'w'))
 153               || ((inits == SCM_EOL) || !SCM_NUMBERP (SCM_CAR (inits))))
 154             *mem = 0;
 155           else
 156             {
 157               *mem = scm_num2long (SCM_CAR (inits), SCM_ARGn, "init_struct");
 158               inits = SCM_CDR (inits);
 159             }
 160           break;
 161 #endif
 162
 163         case 'u':
 164           if (   ((fields_desc[1] != 'r') && (fields_desc[1] != 'w'))
 165               || ((inits == SCM_EOL) || !SCM_NUMBERP (SCM_CAR (inits))))
 166             *mem = 0;
 167           else
 168             {
 169               *mem = scm_num2ulong (SCM_CAR (inits), SCM_ARGn, "init_struct");
 170               inits = SCM_CDR (inits);
 171             }
 172           break;
 173
 174         case 'p':
 175           if (   ((fields_desc[1] != 'r') && (fields_desc[1] != 'w'))
 176               || (inits == SCM_EOL))
 177             *mem = SCM_EOL;
 178           else
 179             {
 180               *mem = SCM_CAR (inits);
 181               inits = SCM_CDR (inits);
 182             }
 183
 184           break;
 185
 186 #if 0
 187         case 'd':
 188           if (   ((fields_desc[1] != 'r') && (fields_desc[1] != 'w'))
 189               || ((inits == SCM_EOL) || !SCM_NUMBERP (SCM_CAR (inits))))
 190             *((double *)mem) = 0.0;
 191           else
 192             {
 193               *mem = scm_num2dbl (SCM_CAR (inits), "init_struct");
 194               inits = SCM_CDR (inits);
 195             }
 196           fields_desc += 2;
 197           break;
 198 #endif
 199
 200         case 's':
 201           *mem = handle;
 202           break;
 203         }
 204
 205       fields_desc += 2;
 206       n_fields--;
 207       mem++;
 208     }
 209 }
 210
 211
 212 SCM_PROC (s_struct_p, "struct?", 1, 0, 0, scm_struct_p);
 213 #ifdef __STDC__
 214 SCM
 215 scm_struct_p (SCM x)
 216 #else
 217 SCM
 218 scm_struct_p (x)
 219      SCM x;
 220 #endif
 221 {
 222   return ((SCM_NIMP (x) && SCM_STRUCTP (x))
 223           ? SCM_BOOL_T
 224           : SCM_BOOL_F);
 225 }
 226
 227 SCM_PROC (s_struct_vtable_p, "struct-vtable?", 1, 0, 0, scm_struct_vtable_p);
 228 #ifdef __STDC__
 229 SCM
 230 scm_struct_vtable_p (SCM x)
 231 #else
 232 SCM
 233 scm_struct_vtable_p (x)
 234      SCM x;
 235 #endif
 236 {
 237   SCM layout;
 238   SCM * mem;
 239
 240   if (SCM_IMP (x))
 241     return SCM_BOOL_F;
 242
 243   if (!SCM_STRUCTP (x))
 244     return SCM_BOOL_F;
 245
 246   layout = SCM_STRUCT_LAYOUT (x);
 247
 248   if (SCM_LENGTH (layout) < SCM_LENGTH (required_vtable_fields))
 249     return SCM_BOOL_F;
 250
 251   if (strncmp (SCM_CHARS (layout), SCM_CHARS (required_vtable_fields),
 252                SCM_LENGTH (required_vtable_fields)))
 253     return SCM_BOOL_F;
 254
 255   mem = SCM_STRUCT_DATA (x);
 256
 257   if (mem[1] != 0)
 258     return SCM_BOOL_F;
 259
 260   if (SCM_IMP (mem[0]))
 261     return SCM_BOOL_F;
 262
 263   return (SCM_SYMBOLP (mem[0])
 264           ? SCM_BOOL_T
 265           : SCM_BOOL_F);
 266 }
 267
 268 SCM_PROC (s_make_struct, "make-struct", 2, 0, 1, scm_make_struct);
 269 #ifdef __STDC__
 270 SCM
 271 scm_make_struct (SCM vtable, SCM tail_array_size, SCM init)
 272 #else
 273 SCM
 274 scm_make_struct (vtable, tail_array_size, init)
 275      SCM vtable;
 276      SCM tail_array_size;
 277      SCM init;
 278 #endif
 279 {
 280   SCM layout;
 281   int basic_size;
 282   int tail_elts;
 283   SCM * data;
 284   SCM handle;
 285
 286   SCM_ASSERT ((SCM_BOOL_F != scm_struct_vtable_p (vtable)),
 287               vtable, SCM_ARG1, s_make_struct);
 288   SCM_ASSERT (SCM_INUMP (tail_array_size), tail_array_size, SCM_ARG2, s_make_struct);
 289
 290   layout = SCM_STRUCT_DATA (vtable)[scm_struct_i_layout];
 291   basic_size = SCM_LENGTH (layout) / 2;
 292   tail_elts = SCM_INUM (tail_array_size);
 293   SCM_NEWCELL (handle);
 294   SCM_DEFER_INTS;
 295   data = (SCM*)scm_must_malloc (sizeof (SCM) * (2 + basic_size + tail_elts), "structure");
 296   *data = (SCM)(2 + basic_size + tail_elts);
 297   data[1] = struct_num++;
 298   data += 2;
 299   SCM_SETCDR (handle, data);
 300   SCM_SETCAR (handle, ((SCM)SCM_STRUCT_DATA (vtable)) + 1);
 301   init_struct (handle, tail_elts, init);
 302   SCM_ALLOW_INTS;
 303   return handle;
 304 }
 305
 306
 307
 308 SCM_PROC (s_make_vtable_vtable, "make-vtable-vtable", 2, 0, 1, scm_make_vtable_vtable);
 309 #ifdef __STDC__
 310 SCM
 311 scm_make_vtable_vtable (SCM extra_fields, SCM tail_array_size, SCM init)
 312 #else
 313 SCM
 314 scm_make_vtable_vtable (extra_fields, tail_array_size, init)
 315      SCM extra_fields;
 316      SCM tail_array_size;
 317      SCM init;
 318 #endif
 319 {
 320   SCM fields;
 321   SCM layout;
 322   int basic_size;
 323   int tail_elts;
 324   SCM * data;
 325   SCM handle;
 326
 327   SCM_ASSERT (SCM_NIMP (extra_fields) && SCM_ROSTRINGP (extra_fields),
 328               extra_fields, SCM_ARG1, s_make_vtable_vtable);
 329   SCM_ASSERT (SCM_INUMP (tail_array_size), tail_array_size, SCM_ARG3, s_make_vtable_vtable);
 330
 331
 332   fields = scm_string_append (scm_listify (required_vtable_fields,
 333                                            extra_fields,
 334                                            SCM_UNDEFINED));
 335   layout = scm_make_struct_layout (fields);
 336   basic_size = SCM_LENGTH (layout) / 2;
 337   tail_elts = SCM_INUM (tail_array_size);
 338   SCM_NEWCELL (handle);
 339   SCM_DEFER_INTS;
 340   data = (SCM*)scm_must_malloc (sizeof (SCM) * (2 + basic_size + tail_elts), "structure");
 341   *data = (SCM)(2 + basic_size + tail_elts);
 342   data[1] = struct_num++;
 343   data += 2;
 344   SCM_SETCDR (handle, data);
 345   SCM_SETCAR (handle, ((SCM)data) + 1);
 346   SCM_STRUCT_LAYOUT (handle) = layout;
 347   init_struct (handle, tail_elts, scm_cons (layout, init));
 348   SCM_ALLOW_INTS;
 349   return handle;
 350 }
 351
 352 \f
 353
 354
 355 SCM_PROC (s_struct_ref, "struct-ref", 2, 0, 0, scm_struct_ref);
 356 #ifdef __STDC__
 357 SCM
 358 scm_struct_ref (SCM handle, SCM pos)
 359 #else
 360 SCM
 361 scm_struct_ref (handle, pos)
 362      SCM handle;
 363      SCM pos;
 364 #endif
 365 {
 366   SCM answer;
 367   SCM * data;
 368   SCM layout;
 369   int p;
 370   int n_fields;
 371   unsigned char * fields_desc;
 372   unsigned char field_type;
 373
 374
 375   SCM_ASSERT (SCM_NIMP (handle) && SCM_STRUCTP (handle), handle,
 376               SCM_ARG1, s_struct_ref);
 377   SCM_ASSERT (SCM_INUMP (pos), pos, SCM_ARG2, s_struct_ref);
 378
 379   layout = SCM_STRUCT_LAYOUT (handle);
 380   data = SCM_STRUCT_DATA (handle);
 381   p = SCM_INUM (pos);
 382
 383   fields_desc = (unsigned char *)SCM_CHARS (layout);
 384   n_fields = SCM_LENGTH (layout) / 2;
 385
 386   SCM_ASSERT (p <= n_fields, pos, SCM_OUTOFRANGE, s_struct_ref);
 387
 388   field_type = fields_desc[p * 2];
 389   {
 390     unsigned char ref;
 391     ref = fields_desc [p * 2 + 1];
 392     if ((ref != 'r') && (ref != 'w'))
 393       {
 394         if ((ref == 'R') || (ref == 'W'))
 395           field_type = 'u';
 396         else
 397           SCM_ASSERT (0, pos, "ref denied", s_struct_ref);
 398       }
 399   }
 400   switch (field_type)
 401     {
 402     case 'u':
 403       answer = scm_ulong2num (data[p]);
 404       break;
 405
 406 #if 0
 407     case 'i':
 408       answer = scm_long2num (data[p]);
 409       break;
 410
 411     case 'd':
 412       answer = scm_makdbl (*((double *)&(data[p])), 0.0);
 413       break;
 414 #endif
 415
 416     case 's':
 417     case 'p':
 418       answer = data[p];
 419       break;
 420
 421
 422     default:
 423       SCM_ASSERT (0, SCM_MAKICHR (field_type), "unrecognized field type", s_struct_ref);
 424       break;
 425     }
 426
 427   return answer;
 428 }
 429
 430
 431 SCM_PROC (s_struct_set_x, "struct-set!", 3, 0, 0, scm_struct_set_x);
 432 #ifdef __STDC__
 433 SCM
 434 scm_struct_set_x (SCM handle, SCM pos, SCM val)
 435 #else
 436 SCM
 437 scm_struct_set_x (handle, pos, val)
 438      SCM handle;
 439      SCM pos;
 440      SCM val;
 441 #endif
 442 {
 443   SCM * data;
 444   SCM layout;
 445   int p;
 446   int n_fields;
 447   unsigned char * fields_desc;
 448   unsigned char field_type;
 449
 450
 451
 452   SCM_ASSERT (SCM_NIMP (handle) && SCM_STRUCTP (handle), handle,
 453               SCM_ARG1, s_struct_ref);
 454   SCM_ASSERT (SCM_INUMP (pos), pos, SCM_ARG2, s_struct_ref);
 455
 456   layout = SCM_STRUCT_LAYOUT (handle);
 457   data = SCM_STRUCT_DATA (handle);
 458   p = SCM_INUM (pos);
 459
 460   fields_desc = (unsigned char *)SCM_CHARS (layout);
 461   n_fields = SCM_LENGTH (layout) / 2;
 462
 463   SCM_ASSERT (p <= n_fields, pos, SCM_OUTOFRANGE, s_struct_set_x);
 464
 465   field_type = fields_desc[p * 2];
 466   {
 467     unsigned char set_x;
 468     set_x = fields_desc [p * 2 + 1];
 469     if (set_x != 'w')
 470       SCM_ASSERT (0, pos, "set_x denied", s_struct_set_x);
 471   }
 472   switch (field_type)
 473     {
 474     case 'u':
 475       data[p] = (SCM)scm_num2ulong (val, (char *)SCM_ARG3, s_struct_set_x);
 476       break;
 477
 478 #if 0
 479     case 'i':
 480       data[p] = scm_num2long (val, (char *)SCM_ARG3, s_struct_set_x);
 481       break;
 482
 483     case 'd':
 484       *((double *)&(data[p])) = scm_num2dbl (val, (char *)SCM_ARG3);
 485       break;
 486 #endif
 487
 488     case 'p':
 489       data[p] = val;
 490       break;
 491
 492     case 's':
 493       SCM_ASSERT (0, SCM_MAKICHR (field_type), "self fields immutable", s_struct_set_x);
 494       break;
 495
 496     default:
 497       SCM_ASSERT (0, SCM_MAKICHR (field_type), "unrecognized field type", s_struct_set_x);
 498       break;
 499     }
 500
 501   return val;
 502 }
 503
 504
 505 SCM_PROC (s_struct_vtable, "struct-vtable", 1, 0, 0, scm_struct_vtable);
 506 #ifdef __STDC__
 507 SCM
 508 scm_struct_vtable (SCM handle)
 509 #else
 510 SCM
 511 scm_struct_vtable (handle)
 512      SCM handle;
 513 #endif
 514 {
 515   SCM_ASSERT (SCM_NIMP (handle) && SCM_STRUCTP (handle), handle,
 516               SCM_ARG1, s_struct_vtable);
 517   return SCM_STRUCT_VTABLE (handle);
 518 }
 519
 520
 521 SCM_PROC (s_struct_vtable_tag, "struct-vtable-tag", 1, 0, 0, scm_struct_vtable_tag);
 522 #ifdef __STDC__
 523 SCM
 524 scm_struct_vtable_tag (SCM handle)
 525 #else
 526 SCM
 527 scm_struct_vtable_tag (handle)
 528      SCM handle;
 529 #endif
 530 {
 531   SCM_ASSERT (SCM_NIMP (handle) && (SCM_BOOL_F != scm_struct_vtable_p (handle)),
 532               handle, SCM_ARG1, s_struct_vtable_tag);
 533   return scm_long2num (SCM_STRUCT_DATA (handle)[-1]);
 534 }
 535
 536
 537 \f
 538
 539 #ifdef __STDC__
 540 void
 541 scm_init_struct (void)
 542 #else
 543 void
 544 scm_init_struct ()
 545 #endif
 546 {
 547   required_vtable_fields = SCM_CAR (scm_intern_obarray ("pruosr", sizeof ("pruosr") - 1, SCM_BOOL_F));
 548   scm_permanent_object (required_vtable_fields);
 549   scm_sysintern ("struct-vtable-offset", SCM_MAKINUM (scm_struct_i_vtable_offset));
 550 #include "struct.x"
 551 }
 552