| 1 | /* Copyright (C) 1996,1997,1998,1999,2000,2001 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 | |
| 42 | /* Software engineering face-lift by Greg J. Badros, 11-Dec-1999, |
| 43 | gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */ |
| 44 | |
| 45 | \f |
| 46 | |
| 47 | #include "libguile/_scm.h" |
| 48 | #include "libguile/chars.h" |
| 49 | #include "libguile/eval.h" |
| 50 | #include "libguile/alist.h" |
| 51 | #include "libguile/weaks.h" |
| 52 | #include "libguile/hashtab.h" |
| 53 | #include "libguile/ports.h" |
| 54 | #include "libguile/strings.h" |
| 55 | |
| 56 | #include "libguile/validate.h" |
| 57 | #include "libguile/struct.h" |
| 58 | |
| 59 | #ifdef HAVE_STRING_H |
| 60 | #include <string.h> |
| 61 | #endif |
| 62 | |
| 63 | \f |
| 64 | |
| 65 | static SCM required_vtable_fields = SCM_BOOL_F; |
| 66 | SCM scm_struct_table; |
| 67 | |
| 68 | \f |
| 69 | SCM_DEFINE (scm_make_struct_layout, "make-struct-layout", 1, 0, 0, |
| 70 | (SCM fields), |
| 71 | "Return a new structure layout object.\n\n" |
| 72 | "@var{fields} must be a string made up of pairs of characters\n" |
| 73 | "strung together. The first character of each pair describes a field\n" |
| 74 | "type, the second a field protection. Allowed types are 'p' for\n" |
| 75 | "GC-protected Scheme data, 'u' for unprotected binary data, and 's' for\n" |
| 76 | "a field that points to the structure itself. Allowed protections\n" |
| 77 | "are 'w' for mutable fields, 'r' for read-only fields, and 'o' for opaque \n" |
| 78 | "fields. The last field protection specification may be capitalized to\n" |
| 79 | "indicate that the field is a tail-array.") |
| 80 | #define FUNC_NAME s_scm_make_struct_layout |
| 81 | { |
| 82 | SCM new_sym; |
| 83 | SCM_VALIDATE_STRING (1, fields); |
| 84 | |
| 85 | { /* scope */ |
| 86 | char * field_desc; |
| 87 | size_t len; |
| 88 | int x; |
| 89 | |
| 90 | len = SCM_STRING_LENGTH (fields); |
| 91 | if (len % 2 == 1) |
| 92 | SCM_MISC_ERROR ("odd length field specification: ~S", |
| 93 | SCM_LIST1 (fields)); |
| 94 | |
| 95 | field_desc = SCM_STRING_CHARS (fields); |
| 96 | |
| 97 | for (x = 0; x < len; x += 2) |
| 98 | { |
| 99 | switch (field_desc[x]) |
| 100 | { |
| 101 | case 'u': |
| 102 | case 'p': |
| 103 | #if 0 |
| 104 | case 'i': |
| 105 | case 'd': |
| 106 | #endif |
| 107 | case 's': |
| 108 | break; |
| 109 | default: |
| 110 | SCM_MISC_ERROR ("unrecognized field type: ~S", |
| 111 | SCM_LIST1 (SCM_MAKE_CHAR (field_desc[x]))); |
| 112 | } |
| 113 | |
| 114 | switch (field_desc[x + 1]) |
| 115 | { |
| 116 | case 'w': |
| 117 | if (field_desc[x] == 's') |
| 118 | SCM_MISC_ERROR ("self fields not writable", SCM_EOL); |
| 119 | case 'r': |
| 120 | case 'o': |
| 121 | break; |
| 122 | case 'R': |
| 123 | case 'W': |
| 124 | case 'O': |
| 125 | if (field_desc[x] == 's') |
| 126 | SCM_MISC_ERROR ("self fields not allowed in tail array", |
| 127 | SCM_EOL); |
| 128 | if (x != len - 2) |
| 129 | SCM_MISC_ERROR ("tail array field must be last field in layout", |
| 130 | SCM_EOL); |
| 131 | break; |
| 132 | default: |
| 133 | SCM_MISC_ERROR ("unrecognized ref specification: ~S", |
| 134 | SCM_LIST1 (SCM_MAKE_CHAR (field_desc[x + 1]))); |
| 135 | } |
| 136 | #if 0 |
| 137 | if (field_desc[x] == 'd') |
| 138 | { |
| 139 | if (field_desc[x + 2] != '-') |
| 140 | SCM_MISC_ERROR ("missing dash field at position ~A", |
| 141 | SCM_LIST1 (SCM_MAKINUM (x / 2))); |
| 142 | x += 2; |
| 143 | goto recheck_ref; |
| 144 | } |
| 145 | #endif |
| 146 | } |
| 147 | new_sym = scm_mem2symbol (field_desc, len); |
| 148 | } |
| 149 | return scm_return_first (new_sym, fields); |
| 150 | } |
| 151 | #undef FUNC_NAME |
| 152 | |
| 153 | \f |
| 154 | |
| 155 | |
| 156 | |
| 157 | static void |
| 158 | scm_struct_init (SCM handle, SCM layout, scm_bits_t * mem, int tail_elts, SCM inits) |
| 159 | { |
| 160 | unsigned char * fields_desc = (unsigned char *) SCM_SYMBOL_CHARS (layout) - 2; |
| 161 | unsigned char prot = 0; |
| 162 | int n_fields = SCM_SYMBOL_LENGTH (layout) / 2; |
| 163 | int tailp = 0; |
| 164 | |
| 165 | while (n_fields) |
| 166 | { |
| 167 | if (!tailp) |
| 168 | { |
| 169 | fields_desc += 2; |
| 170 | prot = fields_desc[1]; |
| 171 | if (SCM_LAYOUT_TAILP (prot)) |
| 172 | { |
| 173 | tailp = 1; |
| 174 | prot = prot == 'R' ? 'r' : prot == 'W' ? 'w' : 'o'; |
| 175 | *mem++ = tail_elts; |
| 176 | n_fields += tail_elts - 1; |
| 177 | if (n_fields == 0) |
| 178 | break; |
| 179 | } |
| 180 | } |
| 181 | |
| 182 | switch (*fields_desc) |
| 183 | { |
| 184 | #if 0 |
| 185 | case 'i': |
| 186 | if ((prot != 'r' && prot != 'w') || inits == SCM_EOL) |
| 187 | *mem = 0; |
| 188 | else |
| 189 | { |
| 190 | *mem = scm_num2long (SCM_CAR (inits), SCM_ARGn, "scm_struct_init"); |
| 191 | inits = SCM_CDR (inits); |
| 192 | } |
| 193 | break; |
| 194 | #endif |
| 195 | |
| 196 | case 'u': |
| 197 | if ((prot != 'r' && prot != 'w') || SCM_NULLP (inits)) |
| 198 | *mem = 0; |
| 199 | else |
| 200 | { |
| 201 | *mem = scm_num2ulong (SCM_CAR (inits), |
| 202 | SCM_ARGn, |
| 203 | "scm_struct_init"); |
| 204 | inits = SCM_CDR (inits); |
| 205 | } |
| 206 | break; |
| 207 | |
| 208 | case 'p': |
| 209 | if ((prot != 'r' && prot != 'w') || SCM_NULLP (inits)) |
| 210 | *mem = SCM_UNPACK (SCM_BOOL_F); |
| 211 | else |
| 212 | { |
| 213 | *mem = SCM_UNPACK (SCM_CAR (inits)); |
| 214 | inits = SCM_CDR (inits); |
| 215 | } |
| 216 | |
| 217 | break; |
| 218 | |
| 219 | #if 0 |
| 220 | case 'd': |
| 221 | if ((prot != 'r' && prot != 'w') || inits == SCM_EOL) |
| 222 | *((double *)mem) = 0.0; |
| 223 | else |
| 224 | { |
| 225 | *mem = scm_num2dbl (SCM_CAR (inits), "scm_struct_init"); |
| 226 | inits = SCM_CDR (inits); |
| 227 | } |
| 228 | fields_desc += 2; |
| 229 | break; |
| 230 | #endif |
| 231 | |
| 232 | case 's': |
| 233 | *mem = SCM_UNPACK (handle); |
| 234 | break; |
| 235 | } |
| 236 | |
| 237 | n_fields--; |
| 238 | mem++; |
| 239 | } |
| 240 | } |
| 241 | |
| 242 | |
| 243 | SCM_DEFINE (scm_struct_p, "struct?", 1, 0, 0, |
| 244 | (SCM x), |
| 245 | "Return @code{#t} iff @var{obj} is a structure object, else\n" |
| 246 | "@code{#f}.") |
| 247 | #define FUNC_NAME s_scm_struct_p |
| 248 | { |
| 249 | return SCM_BOOL(SCM_STRUCTP (x)); |
| 250 | } |
| 251 | #undef FUNC_NAME |
| 252 | |
| 253 | SCM_DEFINE (scm_struct_vtable_p, "struct-vtable?", 1, 0, 0, |
| 254 | (SCM x), |
| 255 | "Return @code{#t} iff obj is a vtable structure.") |
| 256 | #define FUNC_NAME s_scm_struct_vtable_p |
| 257 | { |
| 258 | SCM layout; |
| 259 | scm_bits_t * mem; |
| 260 | |
| 261 | if (!SCM_STRUCTP (x)) |
| 262 | return SCM_BOOL_F; |
| 263 | |
| 264 | layout = SCM_STRUCT_LAYOUT (x); |
| 265 | |
| 266 | if (SCM_SYMBOL_LENGTH (layout) < SCM_STRING_LENGTH (required_vtable_fields)) |
| 267 | return SCM_BOOL_F; |
| 268 | |
| 269 | if (strncmp (SCM_SYMBOL_CHARS (layout), SCM_STRING_CHARS (required_vtable_fields), |
| 270 | SCM_STRING_LENGTH (required_vtable_fields))) |
| 271 | return SCM_BOOL_F; |
| 272 | |
| 273 | mem = SCM_STRUCT_DATA (x); |
| 274 | |
| 275 | if (mem[1] != 0) |
| 276 | return SCM_BOOL_F; |
| 277 | |
| 278 | return SCM_BOOL (SCM_SYMBOLP (SCM_PACK (mem[0]))); |
| 279 | } |
| 280 | #undef FUNC_NAME |
| 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 start 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 | Ugh. */ |
| 311 | |
| 312 | |
| 313 | scm_bits_t * |
| 314 | scm_alloc_struct (int n_words, int n_extra, char *who) |
| 315 | { |
| 316 | int size = sizeof (scm_bits_t) * (n_words + n_extra) + 7; |
| 317 | void * block = scm_must_malloc (size, who); |
| 318 | |
| 319 | /* Adjust the pointer to hide the extra words. */ |
| 320 | scm_bits_t * p = (scm_bits_t *) block + n_extra; |
| 321 | |
| 322 | /* Adjust it even further so it's aligned on an eight-byte boundary. */ |
| 323 | p = (scm_bits_t *) (((scm_bits_t) p + 7) & ~7); |
| 324 | |
| 325 | /* Initialize a few fields as described above. */ |
| 326 | p[scm_struct_i_free] = (scm_bits_t) scm_struct_free_standard; |
| 327 | p[scm_struct_i_ptr] = (scm_bits_t) block; |
| 328 | p[scm_struct_i_n_words] = n_words; |
| 329 | p[scm_struct_i_flags] = 0; |
| 330 | |
| 331 | return p; |
| 332 | } |
| 333 | |
| 334 | size_t |
| 335 | scm_struct_free_0 (scm_bits_t * vtable, scm_bits_t * data) |
| 336 | { |
| 337 | return 0; |
| 338 | } |
| 339 | |
| 340 | size_t |
| 341 | scm_struct_free_light (scm_bits_t * vtable, scm_bits_t * data) |
| 342 | { |
| 343 | scm_must_free (data); |
| 344 | return vtable [scm_struct_i_size] & ~SCM_STRUCTF_MASK; |
| 345 | } |
| 346 | |
| 347 | size_t |
| 348 | scm_struct_free_standard (scm_bits_t * vtable, scm_bits_t * data) |
| 349 | { |
| 350 | size_t n = (data[scm_struct_i_n_words] + scm_struct_n_extra_words) |
| 351 | * sizeof (scm_bits_t) + 7; |
| 352 | scm_must_free ((void *) data[scm_struct_i_ptr]); |
| 353 | return n; |
| 354 | } |
| 355 | |
| 356 | size_t |
| 357 | scm_struct_free_entity (scm_bits_t * vtable, scm_bits_t * data) |
| 358 | { |
| 359 | size_t n = (data[scm_struct_i_n_words] + scm_struct_entity_n_extra_words) |
| 360 | * sizeof (scm_bits_t) + 7; |
| 361 | scm_must_free ((void *) data[scm_struct_i_ptr]); |
| 362 | return n; |
| 363 | } |
| 364 | |
| 365 | static void * |
| 366 | scm_struct_gc_init (void *dummy1, void *dummy2, void *dummy3) |
| 367 | { |
| 368 | scm_structs_to_free = SCM_EOL; |
| 369 | return 0; |
| 370 | } |
| 371 | |
| 372 | static void * |
| 373 | scm_free_structs (void *dummy1, void *dummy2, void *dummy3) |
| 374 | { |
| 375 | SCM newchain = scm_structs_to_free; |
| 376 | do |
| 377 | { |
| 378 | /* Mark vtables in GC chain. GC mark set means delay freeing. */ |
| 379 | SCM chain = newchain; |
| 380 | while (!SCM_NULLP (chain)) |
| 381 | { |
| 382 | SCM vtable = SCM_STRUCT_VTABLE (chain); |
| 383 | if (SCM_STRUCT_GC_CHAIN (vtable) != 0 && vtable != chain) |
| 384 | SCM_SETGCMARK (vtable); |
| 385 | chain = SCM_STRUCT_GC_CHAIN (chain); |
| 386 | } |
| 387 | /* Free unmarked structs. */ |
| 388 | chain = newchain; |
| 389 | newchain = SCM_EOL; |
| 390 | while (!SCM_NULLP (chain)) |
| 391 | { |
| 392 | SCM obj = chain; |
| 393 | chain = SCM_STRUCT_GC_CHAIN (chain); |
| 394 | if (SCM_GCMARKP (obj)) |
| 395 | { |
| 396 | SCM_CLRGCMARK (obj); |
| 397 | SCM_SET_STRUCT_GC_CHAIN (obj, newchain); |
| 398 | newchain = obj; |
| 399 | } |
| 400 | else |
| 401 | { |
| 402 | scm_bits_t word0 = SCM_CELL_WORD_0 (obj) - scm_tc3_cons_gloc; |
| 403 | /* access as struct */ |
| 404 | scm_bits_t * vtable_data = (scm_bits_t *) word0; |
| 405 | scm_bits_t * data = SCM_STRUCT_DATA (obj); |
| 406 | scm_struct_free_t free_struct_data |
| 407 | = ((scm_struct_free_t) vtable_data[scm_struct_i_free]); |
| 408 | SCM_SET_CELL_TYPE (obj, scm_tc_free_cell); |
| 409 | free_struct_data (vtable_data, data); |
| 410 | } |
| 411 | } |
| 412 | } |
| 413 | while (!SCM_NULLP (newchain)); |
| 414 | return 0; |
| 415 | } |
| 416 | |
| 417 | SCM_DEFINE (scm_make_struct, "make-struct", 2, 0, 1, |
| 418 | (SCM vtable, SCM tail_array_size, SCM init), |
| 419 | "Create a new structure.\n\n" |
| 420 | "@var{type} must be a vtable structure (@pxref{Vtables}).\n\n" |
| 421 | "@var{tail-elts} must be a non-negative integer. If the layout\n" |
| 422 | "specification indicated by @var{type} includes a tail-array,\n" |
| 423 | "this is the number of elements allocated to that array.\n\n" |
| 424 | "The @var{init1}, @dots{} are optional arguments describing how\n" |
| 425 | "successive fields of the structure should be initialized. Only fields\n" |
| 426 | "with protection 'r' or 'w' can be initialized, except for fields of\n" |
| 427 | "type 's', which are automatically initialized to point to the new\n" |
| 428 | "structure itself; fields with protection 'o' can not be initialized by\n" |
| 429 | "Scheme programs.\n\n" |
| 430 | "If fewer optional arguments than initializable fields are supplied,\n" |
| 431 | "fields of type 'p' get default value #f while fields of type 'u' are\n" |
| 432 | "initialized to 0.\n\n" |
| 433 | "Structs are currently the basic representation for record-like data\n" |
| 434 | "structures in Guile. The plan is to eventually replace them with a\n" |
| 435 | "new representation which will at the same time be easier to use and\n" |
| 436 | "more powerful.\n\n" |
| 437 | "For more information, see the documentation for @code{make-vtable-vtable}.") |
| 438 | #define FUNC_NAME s_scm_make_struct |
| 439 | { |
| 440 | SCM layout; |
| 441 | int basic_size; |
| 442 | int tail_elts; |
| 443 | scm_bits_t * data; |
| 444 | SCM handle; |
| 445 | |
| 446 | SCM_VALIDATE_VTABLE (1,vtable); |
| 447 | SCM_VALIDATE_INUM (2,tail_array_size); |
| 448 | SCM_VALIDATE_REST_ARGUMENT (init); |
| 449 | |
| 450 | layout = SCM_PACK (SCM_STRUCT_DATA (vtable) [scm_vtable_index_layout]); |
| 451 | basic_size = SCM_SYMBOL_LENGTH (layout) / 2; |
| 452 | tail_elts = SCM_INUM (tail_array_size); |
| 453 | SCM_NEWCELL2 (handle); |
| 454 | SCM_DEFER_INTS; |
| 455 | if (SCM_STRUCT_DATA (vtable)[scm_struct_i_flags] & SCM_STRUCTF_ENTITY) |
| 456 | { |
| 457 | data = scm_alloc_struct (basic_size + tail_elts, |
| 458 | scm_struct_entity_n_extra_words, |
| 459 | "make-struct"); |
| 460 | data[scm_struct_i_procedure] = SCM_UNPACK (SCM_BOOL_F); |
| 461 | data[scm_struct_i_setter] = SCM_UNPACK (SCM_BOOL_F); |
| 462 | } |
| 463 | else |
| 464 | data = scm_alloc_struct (basic_size + tail_elts, |
| 465 | scm_struct_n_extra_words, |
| 466 | "make-struct"); |
| 467 | SCM_SET_CELL_WORD_1 (handle, data); |
| 468 | SCM_SET_STRUCT_GC_CHAIN (handle, 0); |
| 469 | scm_struct_init (handle, layout, data, tail_elts, init); |
| 470 | SCM_SET_CELL_WORD_0 (handle, (scm_bits_t) SCM_STRUCT_DATA (vtable) + scm_tc3_cons_gloc); |
| 471 | SCM_ALLOW_INTS; |
| 472 | return handle; |
| 473 | } |
| 474 | #undef FUNC_NAME |
| 475 | |
| 476 | |
| 477 | |
| 478 | SCM_DEFINE (scm_make_vtable_vtable, "make-vtable-vtable", 2, 0, 1, |
| 479 | (SCM user_fields, SCM tail_array_size, SCM init), |
| 480 | "Return a new, self-describing vtable structure.\n\n" |
| 481 | "@var{user-fields} is a string describing user defined fields of the\n" |
| 482 | "vtable beginning at index @code{vtable-offset-user}\n" |
| 483 | "(see @code{make-struct-layout}).\n\n" |
| 484 | "@var{tail-size} specifies the size of the tail-array (if any) of\n" |
| 485 | "this vtable.\n\n" |
| 486 | "@var{init1}, @dots{} are the optional initializers for the fields of\n" |
| 487 | "the vtable.\n\n" |
| 488 | "Vtables have one initializable system field---the struct printer.\n" |
| 489 | "This field comes before the user fields in the initializers passed\n" |
| 490 | "to @code{make-vtable-vtable} and @code{make-struct}, and thus works as\n" |
| 491 | "a third optional argument to @code{make-vtable-vtable} and a fourth to\n" |
| 492 | "@code{make-struct} when creating vtables:\n\n" |
| 493 | "If the value is a procedure, it will be called instead of the standard\n" |
| 494 | "printer whenever a struct described by this vtable is printed.\n" |
| 495 | "The procedure will be called with arguments STRUCT and PORT.\n\n" |
| 496 | "The structure of a struct is described by a vtable, so the vtable is\n" |
| 497 | "in essence the type of the struct. The vtable is itself a struct with\n" |
| 498 | "a vtable. This could go on forever if it weren't for the\n" |
| 499 | "vtable-vtables which are self-describing vtables, and thus terminate\n" |
| 500 | "the chain.\n\n" |
| 501 | "There are several potential ways of using structs, but the standard\n" |
| 502 | "one is to use three kinds of structs, together building up a type\n" |
| 503 | "sub-system: one vtable-vtable working as the root and one or several\n" |
| 504 | "\"types\", each with a set of \"instances\". (The vtable-vtable should be\n" |
| 505 | "compared to the class <class> which is the class of itself.)\n\n" |
| 506 | "@lisp\n" |
| 507 | "(define ball-root (make-vtable-vtable \"pr\" 0))\n\n" |
| 508 | "(define (make-ball-type ball-color)\n" |
| 509 | " (make-struct ball-root 0\n" |
| 510 | " (make-struct-layout \"pw\")\n" |
| 511 | " (lambda (ball port)\n" |
| 512 | " (format port \"#<a ~A ball owned by ~A>\"\n" |
| 513 | " (color ball)\n" |
| 514 | " (owner ball)))\n" |
| 515 | " ball-color))\n" |
| 516 | "(define (color ball) (struct-ref (struct-vtable ball) vtable-offset-user))\n" |
| 517 | "(define (owner ball) (struct-ref ball 0))\n\n" |
| 518 | "(define red (make-ball-type 'red))\n" |
| 519 | "(define green (make-ball-type 'green))\n\n" |
| 520 | "(define (make-ball type owner) (make-struct type 0 owner))\n\n" |
| 521 | "(define ball (make-ball green 'Nisse))\n" |
| 522 | "ball @result{} #<a green ball owned by Nisse>\n" |
| 523 | "@end lisp\n") |
| 524 | #define FUNC_NAME s_scm_make_vtable_vtable |
| 525 | { |
| 526 | SCM fields; |
| 527 | SCM layout; |
| 528 | int basic_size; |
| 529 | int tail_elts; |
| 530 | scm_bits_t * data; |
| 531 | SCM handle; |
| 532 | |
| 533 | SCM_VALIDATE_STRING (1, user_fields); |
| 534 | SCM_VALIDATE_INUM (2, tail_array_size); |
| 535 | SCM_VALIDATE_REST_ARGUMENT (init); |
| 536 | |
| 537 | fields = scm_string_append (SCM_LIST2 (required_vtable_fields, user_fields)); |
| 538 | layout = scm_make_struct_layout (fields); |
| 539 | basic_size = SCM_SYMBOL_LENGTH (layout) / 2; |
| 540 | tail_elts = SCM_INUM (tail_array_size); |
| 541 | SCM_NEWCELL2 (handle); |
| 542 | SCM_DEFER_INTS; |
| 543 | data = scm_alloc_struct (basic_size + tail_elts, |
| 544 | scm_struct_n_extra_words, |
| 545 | "make-vtable-vtable"); |
| 546 | SCM_SET_CELL_WORD_1 (handle, data); |
| 547 | SCM_SET_STRUCT_GC_CHAIN (handle, 0); |
| 548 | data [scm_vtable_index_layout] = SCM_UNPACK (layout); |
| 549 | scm_struct_init (handle, layout, data, tail_elts, scm_cons (layout, init)); |
| 550 | SCM_SET_CELL_WORD_0 (handle, (scm_bits_t) data + scm_tc3_cons_gloc); |
| 551 | SCM_ALLOW_INTS; |
| 552 | return handle; |
| 553 | } |
| 554 | #undef FUNC_NAME |
| 555 | |
| 556 | \f |
| 557 | |
| 558 | |
| 559 | SCM_DEFINE (scm_struct_ref, "struct-ref", 2, 0, 0, |
| 560 | (SCM handle, SCM pos), |
| 561 | "@deffnx primitive struct-set! struct n value\n" |
| 562 | "Access (or modify) the @var{n}th field of @var{struct}.\n\n" |
| 563 | "If the field is of type 'p', then it can be set to an arbitrary value.\n\n" |
| 564 | "If the field is of type 'u', then it can only be set to a non-negative\n" |
| 565 | "integer value small enough to fit in one machine word.") |
| 566 | #define FUNC_NAME s_scm_struct_ref |
| 567 | { |
| 568 | SCM answer = SCM_UNDEFINED; |
| 569 | scm_bits_t * data; |
| 570 | SCM layout; |
| 571 | int p; |
| 572 | scm_bits_t n_fields; |
| 573 | char * fields_desc; |
| 574 | char field_type = 0; |
| 575 | |
| 576 | |
| 577 | SCM_VALIDATE_STRUCT (1,handle); |
| 578 | SCM_VALIDATE_INUM (2,pos); |
| 579 | |
| 580 | layout = SCM_STRUCT_LAYOUT (handle); |
| 581 | data = SCM_STRUCT_DATA (handle); |
| 582 | p = SCM_INUM (pos); |
| 583 | |
| 584 | fields_desc = SCM_SYMBOL_CHARS (layout); |
| 585 | n_fields = data[scm_struct_i_n_words]; |
| 586 | |
| 587 | SCM_ASSERT_RANGE(1,pos, p < n_fields); |
| 588 | |
| 589 | if (p * 2 < SCM_SYMBOL_LENGTH (layout)) |
| 590 | { |
| 591 | char ref; |
| 592 | field_type = fields_desc[p * 2]; |
| 593 | ref = fields_desc[p * 2 + 1]; |
| 594 | if ((ref != 'r') && (ref != 'w')) |
| 595 | { |
| 596 | if ((ref == 'R') || (ref == 'W')) |
| 597 | field_type = 'u'; |
| 598 | else |
| 599 | SCM_MISC_ERROR ("ref denied for field ~A", SCM_LIST1 (pos)); |
| 600 | } |
| 601 | } |
| 602 | else if (fields_desc[SCM_SYMBOL_LENGTH (layout) - 1] != 'O') |
| 603 | field_type = fields_desc[SCM_SYMBOL_LENGTH (layout) - 2]; |
| 604 | else |
| 605 | SCM_MISC_ERROR ("ref denied for field ~A", SCM_LIST1 (pos)); |
| 606 | |
| 607 | switch (field_type) |
| 608 | { |
| 609 | case 'u': |
| 610 | answer = scm_ulong2num (data[p]); |
| 611 | break; |
| 612 | |
| 613 | #if 0 |
| 614 | case 'i': |
| 615 | answer = scm_long2num (data[p]); |
| 616 | break; |
| 617 | |
| 618 | case 'd': |
| 619 | answer = scm_make_real (*((double *)&(data[p]))); |
| 620 | break; |
| 621 | #endif |
| 622 | |
| 623 | case 's': |
| 624 | case 'p': |
| 625 | answer = SCM_PACK (data[p]); |
| 626 | break; |
| 627 | |
| 628 | |
| 629 | default: |
| 630 | SCM_MISC_ERROR ("unrecognized field type: ~S", |
| 631 | SCM_LIST1 (SCM_MAKE_CHAR (field_type))); |
| 632 | } |
| 633 | |
| 634 | return answer; |
| 635 | } |
| 636 | #undef FUNC_NAME |
| 637 | |
| 638 | |
| 639 | SCM_DEFINE (scm_struct_set_x, "struct-set!", 3, 0, 0, |
| 640 | (SCM handle, SCM pos, SCM val), |
| 641 | "Set the slot of the structure @var{handle} with index @var{pos}\n" |
| 642 | "to @var{val}. Signal an error if the slot can not be written\n" |
| 643 | "to.") |
| 644 | #define FUNC_NAME s_scm_struct_set_x |
| 645 | { |
| 646 | scm_bits_t * data; |
| 647 | SCM layout; |
| 648 | int p; |
| 649 | int n_fields; |
| 650 | char * fields_desc; |
| 651 | char field_type = 0; |
| 652 | |
| 653 | SCM_VALIDATE_STRUCT (1,handle); |
| 654 | SCM_VALIDATE_INUM (2,pos); |
| 655 | |
| 656 | layout = SCM_STRUCT_LAYOUT (handle); |
| 657 | data = SCM_STRUCT_DATA (handle); |
| 658 | p = SCM_INUM (pos); |
| 659 | |
| 660 | fields_desc = SCM_SYMBOL_CHARS (layout); |
| 661 | n_fields = data[scm_struct_i_n_words]; |
| 662 | |
| 663 | SCM_ASSERT_RANGE (1,pos, p < n_fields); |
| 664 | |
| 665 | if (p * 2 < SCM_SYMBOL_LENGTH (layout)) |
| 666 | { |
| 667 | char set_x; |
| 668 | field_type = fields_desc[p * 2]; |
| 669 | set_x = fields_desc [p * 2 + 1]; |
| 670 | if (set_x != 'w') |
| 671 | SCM_MISC_ERROR ("set! denied for field ~A", SCM_LIST1 (pos)); |
| 672 | } |
| 673 | else if (fields_desc[SCM_SYMBOL_LENGTH (layout) - 1] == 'W') |
| 674 | field_type = fields_desc[SCM_SYMBOL_LENGTH (layout) - 2]; |
| 675 | else |
| 676 | SCM_MISC_ERROR ("set! denied for field ~A", SCM_LIST1 (pos)); |
| 677 | |
| 678 | switch (field_type) |
| 679 | { |
| 680 | case 'u': |
| 681 | data[p] = SCM_NUM2ULONG (3, val); |
| 682 | break; |
| 683 | |
| 684 | #if 0 |
| 685 | case 'i': |
| 686 | data[p] = SCM_NUM2LONG (3, val); |
| 687 | break; |
| 688 | |
| 689 | case 'd': |
| 690 | *((double *)&(data[p])) = scm_num2dbl (val, (char *)SCM_ARG3); |
| 691 | break; |
| 692 | #endif |
| 693 | |
| 694 | case 'p': |
| 695 | data[p] = SCM_UNPACK (val); |
| 696 | break; |
| 697 | |
| 698 | case 's': |
| 699 | SCM_MISC_ERROR ("self fields immutable", SCM_EOL); |
| 700 | |
| 701 | default: |
| 702 | SCM_MISC_ERROR ("unrecognized field type: ~S", |
| 703 | SCM_LIST1 (SCM_MAKE_CHAR (field_type))); |
| 704 | } |
| 705 | |
| 706 | return val; |
| 707 | } |
| 708 | #undef FUNC_NAME |
| 709 | |
| 710 | |
| 711 | SCM_DEFINE (scm_struct_vtable, "struct-vtable", 1, 0, 0, |
| 712 | (SCM handle), |
| 713 | "Return the vtable structure that describes the type of @var{struct}.") |
| 714 | #define FUNC_NAME s_scm_struct_vtable |
| 715 | { |
| 716 | SCM_VALIDATE_STRUCT (1,handle); |
| 717 | return SCM_STRUCT_VTABLE (handle); |
| 718 | } |
| 719 | #undef FUNC_NAME |
| 720 | |
| 721 | |
| 722 | SCM_DEFINE (scm_struct_vtable_tag, "struct-vtable-tag", 1, 0, 0, |
| 723 | (SCM handle), |
| 724 | "Return the vtable tag of the structure @var{handle}.") |
| 725 | #define FUNC_NAME s_scm_struct_vtable_tag |
| 726 | { |
| 727 | SCM_VALIDATE_VTABLE (1,handle); |
| 728 | return scm_long2num ((long) SCM_STRUCT_DATA (handle) >> 3); |
| 729 | } |
| 730 | #undef FUNC_NAME |
| 731 | |
| 732 | /* {Associating names and classes with vtables} |
| 733 | * |
| 734 | * The name of a vtable should probably be stored as a slot. This is |
| 735 | * a backward compatible solution until agreement has been achieved on |
| 736 | * how to associate names with vtables. |
| 737 | */ |
| 738 | |
| 739 | scm_bits_t |
| 740 | scm_struct_ihashq (SCM obj, scm_bits_t n) |
| 741 | { |
| 742 | /* The length of the hash table should be a relative prime it's not |
| 743 | necessary to shift down the address. */ |
| 744 | return SCM_UNPACK (obj) % n; |
| 745 | } |
| 746 | |
| 747 | SCM |
| 748 | scm_struct_create_handle (SCM obj) |
| 749 | { |
| 750 | SCM handle = scm_hash_fn_create_handle_x (scm_struct_table, |
| 751 | obj, |
| 752 | SCM_BOOL_F, |
| 753 | scm_struct_ihashq, |
| 754 | scm_sloppy_assq, |
| 755 | 0); |
| 756 | if (SCM_FALSEP (SCM_CDR (handle))) |
| 757 | SCM_SETCDR (handle, scm_cons (SCM_BOOL_F, SCM_BOOL_F)); |
| 758 | return handle; |
| 759 | } |
| 760 | |
| 761 | SCM_DEFINE (scm_struct_vtable_name, "struct-vtable-name", 1, 0, 0, |
| 762 | (SCM vtable), |
| 763 | "Return the name of the vtable @var{vtable}.") |
| 764 | #define FUNC_NAME s_scm_struct_vtable_name |
| 765 | { |
| 766 | SCM_VALIDATE_VTABLE (1,vtable); |
| 767 | return SCM_STRUCT_TABLE_NAME (SCM_CDR (scm_struct_create_handle (vtable))); |
| 768 | } |
| 769 | #undef FUNC_NAME |
| 770 | |
| 771 | SCM_DEFINE (scm_set_struct_vtable_name_x, "set-struct-vtable-name!", 2, 0, 0, |
| 772 | (SCM vtable, SCM name), |
| 773 | "Set the name of the vtable @var{vtable} to @var{name}.") |
| 774 | #define FUNC_NAME s_scm_set_struct_vtable_name_x |
| 775 | { |
| 776 | SCM_VALIDATE_VTABLE (1,vtable); |
| 777 | SCM_VALIDATE_SYMBOL (2,name); |
| 778 | SCM_SET_STRUCT_TABLE_NAME (SCM_CDR (scm_struct_create_handle (vtable)), |
| 779 | name); |
| 780 | return SCM_UNSPECIFIED; |
| 781 | } |
| 782 | #undef FUNC_NAME |
| 783 | |
| 784 | |
| 785 | \f |
| 786 | |
| 787 | void |
| 788 | scm_print_struct (SCM exp, SCM port, scm_print_state *pstate) |
| 789 | { |
| 790 | if (SCM_NFALSEP (scm_procedure_p (SCM_STRUCT_PRINTER (exp)))) |
| 791 | scm_printer_apply (SCM_STRUCT_PRINTER (exp), exp, port, pstate); |
| 792 | else |
| 793 | { |
| 794 | SCM vtable = SCM_STRUCT_VTABLE (exp); |
| 795 | SCM name = scm_struct_vtable_name (vtable); |
| 796 | scm_puts ("#<", port); |
| 797 | if (SCM_NFALSEP (name)) |
| 798 | scm_display (name, port); |
| 799 | else |
| 800 | scm_puts ("struct", port); |
| 801 | scm_putc (' ', port); |
| 802 | scm_intprint (SCM_UNPACK (vtable), 16, port); |
| 803 | scm_putc (':', port); |
| 804 | scm_intprint (SCM_UNPACK (exp), 16, port); |
| 805 | scm_putc ('>', port); |
| 806 | } |
| 807 | } |
| 808 | |
| 809 | void |
| 810 | scm_struct_prehistory () |
| 811 | { |
| 812 | scm_c_hook_add (&scm_before_mark_c_hook, scm_struct_gc_init, 0, 0); |
| 813 | scm_c_hook_add (&scm_after_sweep_c_hook, scm_free_structs, 0, 0); |
| 814 | } |
| 815 | |
| 816 | void |
| 817 | scm_init_struct () |
| 818 | { |
| 819 | scm_struct_table |
| 820 | = scm_permanent_object (scm_make_weak_key_hash_table (SCM_MAKINUM (31))); |
| 821 | required_vtable_fields = scm_makfrom0str ("pruosrpw"); |
| 822 | scm_permanent_object (required_vtable_fields); |
| 823 | scm_c_define ("vtable-index-layout", SCM_MAKINUM (scm_vtable_index_layout)); |
| 824 | scm_c_define ("vtable-index-vtable", SCM_MAKINUM (scm_vtable_index_vtable)); |
| 825 | scm_c_define ("vtable-index-printer", |
| 826 | SCM_MAKINUM (scm_vtable_index_printer)); |
| 827 | scm_c_define ("vtable-offset-user", SCM_MAKINUM (scm_vtable_offset_user)); |
| 828 | #ifndef SCM_MAGIC_SNARFER |
| 829 | #include "libguile/struct.x" |
| 830 | #endif |
| 831 | } |
| 832 | |
| 833 | /* |
| 834 | Local Variables: |
| 835 | c-file-style: "gnu" |
| 836 | End: |
| 837 | */ |