1 /* Copyright (C) 1996, 97, 98, 99, 2000 Free Software Foundation, Inc.
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)
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.
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
18 * As a special exception, the Free Software Foundation gives permission
19 * for additional uses of the text contained in its release of GUILE.
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.
27 * This exception does not however invalidate any other reasons why
28 * the executable file might be covered by the GNU General Public License.
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.
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. */
42 /* Software engineering face-lift by Greg J. Badros, 11-Dec-1999,
43 gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */
66 static SCM required_vtable_fields
= SCM_BOOL_F
;
70 SCM_DEFINE (scm_make_struct_layout
, "make-struct-layout", 1, 0, 0,
72 "Return a new structure layout object.\n\n"
73 "@var{fields} must be a read-only string made up of pairs of characters\n"
74 "strung together. The first character of each pair describes a field\n"
75 "type, the second a field protection. Allowed types are 'p' for\n"
76 "GC-protected Scheme data, 'u' for unprotected binary data, and 's' for\n"
77 "fields that should point to the structure itself. Allowed protections\n"
78 "are 'w' for mutable fields, 'r' for read-only fields, and 'o' for opaque \n"
79 "fields. The last field protection specification may be capitalized to\n"
80 "indicate that the field is a tail-array.")
81 #define FUNC_NAME s_scm_make_struct_layout
84 SCM_VALIDATE_ROSTRING (1,fields
);
90 len
= SCM_ROLENGTH (fields
);
91 field_desc
= SCM_ROCHARS (fields
);
92 SCM_ASSERT (!(len
& 1), fields
, "odd length field specification", FUNC_NAME
);
94 for (x
= 0; x
< len
; x
+= 2)
96 switch (field_desc
[x
])
107 SCM_ASSERT (0, SCM_MAKE_CHAR (field_desc
[x
]) , "unrecognized field type", FUNC_NAME
);
110 switch (field_desc
[x
+ 1])
113 SCM_ASSERT (field_desc
[x
] != 's', SCM_MAKE_CHAR (field_desc
[x
+ 1]),
114 "self fields not writable", FUNC_NAME
);
122 SCM_ASSERT (field_desc
[x
] != 's', SCM_MAKE_CHAR (field_desc
[x
+ 1]),
123 "self fields not allowed in tail array",
125 SCM_ASSERT (x
== len
- 2, SCM_MAKE_CHAR (field_desc
[x
+ 1]),
126 "tail array field must be last field in layout",
130 SCM_ASSERT (0, SCM_MAKE_CHAR (field_desc
[x
]) , "unrecognized ref specification", FUNC_NAME
);
133 if (field_desc
[x
] == 'd')
135 SCM_ASSERT (field_desc
[x
+ 2] == '-', SCM_MAKINUM (x
/ 2), "missing dash field", FUNC_NAME
);
141 new_sym
= SCM_CAR (scm_intern_obarray (field_desc
, len
, SCM_BOOL_F
));
143 return scm_return_first (new_sym
, fields
);
152 scm_struct_init (SCM handle
, int tail_elts
, SCM inits
)
156 unsigned char * fields_desc
;
157 unsigned char prot
= 0;
162 layout
= SCM_STRUCT_LAYOUT (handle
);
163 data
= SCM_STRUCT_DATA (handle
);
164 fields_desc
= (unsigned char *) SCM_CHARS (layout
) - 2;
165 n_fields
= SCM_LENGTH (layout
) / 2;
166 mem
= SCM_STRUCT_DATA (handle
);
172 prot
= fields_desc
[1];
173 if (SCM_LAYOUT_TAILP (prot
))
176 prot
= prot
== 'R' ? 'r' : prot
== 'W' ? 'w' : 'o';
177 *mem
++ = SCM_PACK (tail_elts
);
178 n_fields
+= tail_elts
- 1;
184 switch (*fields_desc
)
188 if ((prot
!= 'r' && prot
!= 'w') || inits
== SCM_EOL
)
192 *mem
= scm_num2long (SCM_CAR (inits
), SCM_ARGn
, "scm_struct_init");
193 inits
= SCM_CDR (inits
);
199 if ((prot
!= 'r' && prot
!= 'w') || inits
== SCM_EOL
)
203 *mem
= SCM_PACK (scm_num2ulong (SCM_CAR (inits
),
206 inits
= SCM_CDR (inits
);
211 if ((prot
!= 'r' && prot
!= 'w') || inits
== SCM_EOL
)
215 *mem
= SCM_CAR (inits
);
216 inits
= SCM_CDR (inits
);
223 if ((prot
!= 'r' && prot
!= 'w') || inits
== SCM_EOL
)
224 *((double *)mem
) = 0.0;
227 *mem
= scm_num2dbl (SCM_CAR (inits
), "scm_struct_init");
228 inits
= SCM_CDR (inits
);
245 SCM_DEFINE (scm_struct_p
, "struct?", 1, 0, 0,
247 "Return #t iff @var{obj} is a structure object, else #f.")
248 #define FUNC_NAME s_scm_struct_p
250 return SCM_BOOL(SCM_STRUCTP (x
));
254 SCM_DEFINE (scm_struct_vtable_p
, "struct-vtable?", 1, 0, 0,
256 "Return #t iff obj is a vtable structure.")
257 #define FUNC_NAME s_scm_struct_vtable_p
265 if (!SCM_STRUCTP (x
))
268 layout
= SCM_STRUCT_LAYOUT (x
);
270 if (SCM_LENGTH (layout
) < SCM_LENGTH (required_vtable_fields
))
273 if (strncmp (SCM_CHARS (layout
), SCM_CHARS (required_vtable_fields
),
274 SCM_LENGTH (required_vtable_fields
)))
277 mem
= SCM_STRUCT_DATA (x
);
282 if (SCM_IMP (mem
[0]))
285 return SCM_BOOL(SCM_SYMBOLP (mem
[0]));
290 /* All struct data must be allocated at an address whose bottom three
291 bits are zero. This is because the tag for a struct lives in the
292 bottom three bits of the struct's car, and the upper bits point to
293 the data of its vtable, which is a struct itself. Thus, if the
294 address of that data doesn't end in three zeros, tagging it will
297 This function allocates a block of memory, and returns a pointer at
298 least scm_struct_n_extra_words words into the block. Furthermore,
299 it guarantees that that pointer's least three significant bits are
302 The argument n_words should be the number of words that should
303 appear after the returned address. (That is, it shouldn't include
304 scm_struct_n_extra_words.)
306 This function initializes the following fields of the struct:
308 scm_struct_i_ptr --- the actual start of the block of memory; the
309 address you should pass to 'free' to dispose of the block.
310 This field allows us to both guarantee that the returned
311 address is divisible by eight, and allow the GC to free the
314 scm_struct_i_n_words --- the number of words allocated to the
315 block, including the extra fields. This is used by the GC.
321 scm_alloc_struct (int n_words
, int n_extra
, char *who
)
323 int size
= sizeof (SCM
) * (n_words
+ n_extra
) + 7;
324 SCM
*block
= (SCM
*) scm_must_malloc (size
, who
);
326 /* Adjust the pointer to hide the extra words. */
327 SCM
*p
= block
+ n_extra
;
329 /* Adjust it even further so it's aligned on an eight-byte boundary. */
330 p
= (SCM
*) (((scm_bits_t
) SCM_UNPACK (p
) + 7) & ~7);
332 /* Initialize a few fields as described above. */
333 p
[scm_struct_i_free
] = (SCM
) scm_struct_free_standard
;
334 p
[scm_struct_i_ptr
] = (SCM
) block
;
335 p
[scm_struct_i_n_words
] = (SCM
) n_words
;
336 p
[scm_struct_i_flags
] = 0;
342 scm_struct_free_0 (SCM
*vtable
, SCM
*data
)
348 scm_struct_free_light (SCM
*vtable
, SCM
*data
)
351 return SCM_UNPACK (vtable
[scm_struct_i_size
]) & ~SCM_STRUCTF_MASK
;
355 scm_struct_free_standard (SCM
*vtable
, SCM
*data
)
357 size_t n
= ((SCM_UNPACK (data
[scm_struct_i_n_words
]) + scm_struct_n_extra_words
)
359 free ((void *) data
[scm_struct_i_ptr
]);
364 scm_struct_free_entity (SCM
*vtable
, SCM
*data
)
366 size_t n
= (SCM_UNPACK(data
[scm_struct_i_n_words
] + scm_struct_entity_n_extra_words
)
368 free ((void *) data
[scm_struct_i_ptr
]);
372 SCM_DEFINE (scm_make_struct
, "make-struct", 2, 0, 1,
373 (SCM vtable
, SCM tail_array_size
, SCM init
),
374 "Create a new structure.\n\n"
375 "@var{type} must be a vtable structure (@xref{Vtables}).\n\n"
376 "@var{tail-elts} must be a non-negative integer. If the layout\n"
377 "specification indicated by @var{type} includes a tail-array,\n"
378 "this is the number of elements allocated to that array.\n\n"
379 "The @var{inits} are optional arguments describing how successive fields\n"
380 "of the structure should be initialized. Only fields with protection 'r'\n"
381 "or 'w' can be initialized -- fields of protection 's' are automatically\n"
382 "initialized to point to the new structure itself; fields of protection 'o'\n"
383 "can not be initialized by Scheme programs.")
384 #define FUNC_NAME s_scm_make_struct
392 SCM_VALIDATE_VTABLE (1,vtable
);
393 SCM_VALIDATE_INUM (2,tail_array_size
);
395 layout
= SCM_STRUCT_DATA (vtable
)[scm_vtable_index_layout
];
396 basic_size
= SCM_LENGTH (layout
) / 2;
397 tail_elts
= SCM_INUM (tail_array_size
);
398 SCM_NEWCELL (handle
);
400 if (SCM_UNPACK (SCM_STRUCT_DATA (vtable
)[scm_struct_i_flags
]) & SCM_STRUCTF_ENTITY
)
402 data
= scm_alloc_struct (basic_size
+ tail_elts
,
403 scm_struct_entity_n_extra_words
,
405 data
[scm_struct_i_procedure
] = SCM_BOOL_F
;
406 data
[scm_struct_i_setter
] = SCM_BOOL_F
;
409 data
= scm_alloc_struct (basic_size
+ tail_elts
,
410 scm_struct_n_extra_words
,
412 SCM_SETCDR (handle
, data
);
413 SCM_SETCAR (handle
, ((SCM
)SCM_STRUCT_DATA (vtable
)) + scm_tc3_cons_gloc
);
414 scm_struct_init (handle
, tail_elts
, init
);
422 SCM_DEFINE (scm_make_vtable_vtable
, "make-vtable-vtable", 2, 0, 1,
423 (SCM extra_fields
, SCM tail_array_size
, SCM init
),
424 "Return a new, self-describing vtable structure.\n\n"
425 "@var{new-fields} is a layout specification describing fields\n"
426 "of the resulting structure beginning at the position bound to\n"
427 "@code{vtable-offset-user}.\n\n"
428 "@var{tail-size} specifies the size of the tail-array (if any) of\n"
430 "@var{inits} initializes the fields of the vtable. Minimally, one\n"
431 "initializer must be provided: the layout specification for instances\n"
432 "of the type this vtable will describe. If a second initializer is\n"
433 "provided, it will be interpreted as a print call-back function.\n\n"
435 ";;; loading ,a...\n"
437 " (make-vtable-vtable (make-struct-layout (quote pw))\n"
442 "(struct-vtable? x)\n"
444 "(eq? x (struct-vtable x))\n"
446 "(struct-ref x vtable-offset-user)\n"
449 "@result{} pruosrpwpw\n\n\n"
453 " (make-struct-layout (quote pwpwpw))\n"
457 "(struct-vtable? y)\n"
461 "(eq? x (struct-vtable y))\n"
465 "(struct-ref y vtable-offset-user)\n"
466 "@result{} bar\n\n\n"
467 "(define z (make-struct y 0 'a 'b 'c))\n\n"
470 "(struct-vtable? z)\n"
472 "(eq? y (struct-vtable z))\n"
474 "(map (lambda (n) (struct-ref z n)) '(0 1 2))\n"
475 "@result{} (a b c)\n"
478 #define FUNC_NAME s_scm_make_vtable_vtable
487 SCM_VALIDATE_ROSTRING (1,extra_fields
);
488 SCM_VALIDATE_INUM (2,tail_array_size
);
490 fields
= scm_string_append (scm_listify (required_vtable_fields
,
493 layout
= scm_make_struct_layout (fields
);
494 basic_size
= SCM_LENGTH (layout
) / 2;
495 tail_elts
= SCM_INUM (tail_array_size
);
496 SCM_NEWCELL (handle
);
498 data
= scm_alloc_struct (basic_size
+ tail_elts
,
499 scm_struct_n_extra_words
,
500 "make-vtable-vtable");
501 SCM_SETCDR (handle
, data
);
502 SCM_SETCAR (handle
, ((SCM
)data
) + scm_tc3_cons_gloc
);
503 SCM_STRUCT_LAYOUT (handle
) = layout
;
504 scm_struct_init (handle
, tail_elts
, scm_cons (layout
, init
));
513 SCM_DEFINE (scm_struct_ref
, "struct-ref", 2, 0, 0,
514 (SCM handle
, SCM pos
),
515 "@deffnx primitive struct-set! struct n value\n"
516 "Access (or modify) the @var{n}th field of @var{struct}.\n\n"
517 "If the field is of type 'p', then it can be set to an arbitrary value.\n\n"
518 "If the field is of type 'u', then it can only be set to a non-negative\n"
519 "integer value small enough to fit in one machine word.")
520 #define FUNC_NAME s_scm_struct_ref
522 SCM answer
= SCM_UNDEFINED
;
527 unsigned char * fields_desc
;
528 unsigned char field_type
= 0;
531 SCM_VALIDATE_STRUCT (1,handle
);
532 SCM_VALIDATE_INUM (2,pos
);
534 layout
= SCM_STRUCT_LAYOUT (handle
);
535 data
= SCM_STRUCT_DATA (handle
);
538 fields_desc
= (unsigned char *) SCM_CHARS (layout
);
539 n_fields
= SCM_UNPACK (data
[scm_struct_i_n_words
]);
541 SCM_ASSERT_RANGE(1,pos
, p
< n_fields
);
543 if (p
* 2 < SCM_LENGTH (layout
))
546 field_type
= fields_desc
[p
* 2];
547 ref
= fields_desc
[p
* 2 + 1];
548 if ((ref
!= 'r') && (ref
!= 'w'))
550 if ((ref
== 'R') || (ref
== 'W'))
553 SCM_ASSERT (0, pos
, "ref denied", FUNC_NAME
);
556 else if (fields_desc
[SCM_LENGTH (layout
) - 1] != 'O')
557 field_type
= fields_desc
[SCM_LENGTH (layout
) - 2];
560 SCM_ASSERT (0, pos
, "ref denied", FUNC_NAME
);
567 answer
= scm_ulong2num (SCM_UNPACK (data
[p
]));
572 answer
= scm_long2num (data
[p
]);
576 answer
= scm_makdbl (*((double *)&(data
[p
])), 0.0);
587 SCM_ASSERT (0, SCM_MAKE_CHAR (field_type
), "unrecognized field type", FUNC_NAME
);
596 SCM_DEFINE (scm_struct_set_x
, "struct-set!", 3, 0, 0,
597 (SCM handle
, SCM pos
, SCM val
),
599 #define FUNC_NAME s_scm_struct_set_x
605 unsigned char * fields_desc
;
606 unsigned char field_type
= 0;
608 SCM_VALIDATE_STRUCT (1,handle
);
609 SCM_VALIDATE_INUM (2,pos
);
611 layout
= SCM_STRUCT_LAYOUT (handle
);
612 data
= SCM_STRUCT_DATA (handle
);
615 fields_desc
= (unsigned char *)SCM_CHARS (layout
);
616 n_fields
= SCM_UNPACK (data
[scm_struct_i_n_words
]);
618 SCM_ASSERT_RANGE (1,pos
, p
< n_fields
);
620 if (p
* 2 < SCM_LENGTH (layout
))
623 field_type
= fields_desc
[p
* 2];
624 set_x
= fields_desc
[p
* 2 + 1];
626 SCM_ASSERT (0, pos
, "set_x denied", FUNC_NAME
);
628 else if (fields_desc
[SCM_LENGTH (layout
) - 1] == 'W')
629 field_type
= fields_desc
[SCM_LENGTH (layout
) - 2];
632 SCM_ASSERT (0, pos
, "set_x denied", FUNC_NAME
);
639 data
[p
] = SCM_PACK (SCM_NUM2ULONG (3, val
));
644 data
[p
] = SCM_NUM2LONG (3,val
);
648 *((double *)&(data
[p
])) = scm_num2dbl (val
, (char *)SCM_ARG3
);
657 SCM_ASSERT (0, SCM_MAKE_CHAR (field_type
), "self fields immutable", FUNC_NAME
);
661 SCM_ASSERT (0, SCM_MAKE_CHAR (field_type
), "unrecognized field type", FUNC_NAME
);
670 SCM_DEFINE (scm_struct_vtable
, "struct-vtable", 1, 0, 0,
672 "Return the vtable structure that describes the type of @var{struct}.")
673 #define FUNC_NAME s_scm_struct_vtable
675 SCM_VALIDATE_STRUCT (1,handle
);
676 return SCM_STRUCT_VTABLE (handle
);
681 SCM_DEFINE (scm_struct_vtable_tag
, "struct-vtable-tag", 1, 0, 0,
684 #define FUNC_NAME s_scm_struct_vtable_tag
686 SCM_VALIDATE_VTABLE (1,handle
);
687 return scm_long2num ((long) SCM_STRUCT_DATA (handle
) >> 3);
691 /* {Associating names and classes with vtables}
693 * The name of a vtable should probably be stored as a slot. This is
694 * a backward compatible solution until agreement has been achieved on
695 * how to associate names with vtables.
699 scm_struct_ihashq (SCM obj
, unsigned int n
)
701 /* The length of the hash table should be a relative prime it's not
702 necessary to shift down the address. */
703 return SCM_UNPACK (obj
) % n
;
707 scm_struct_create_handle (SCM obj
)
709 SCM handle
= scm_hash_fn_create_handle_x (scm_struct_table
,
715 if (SCM_FALSEP (SCM_CDR (handle
)))
716 SCM_SETCDR (handle
, scm_cons (SCM_BOOL_F
, SCM_BOOL_F
));
720 SCM_DEFINE (scm_struct_vtable_name
, "struct-vtable-name", 1, 0, 0,
723 #define FUNC_NAME s_scm_struct_vtable_name
725 SCM_VALIDATE_VTABLE (1,vtable
);
726 return SCM_STRUCT_TABLE_NAME (SCM_CDR (scm_struct_create_handle (vtable
)));
730 SCM_DEFINE (scm_set_struct_vtable_name_x
, "set-struct-vtable-name!", 2, 0, 0,
731 (SCM vtable
, SCM name
),
733 #define FUNC_NAME s_scm_set_struct_vtable_name_x
735 SCM_VALIDATE_VTABLE (1,vtable
);
736 SCM_VALIDATE_SYMBOL (2,name
);
737 SCM_SET_STRUCT_TABLE_NAME (SCM_CDR (scm_struct_create_handle (vtable
)),
739 return SCM_UNSPECIFIED
;
747 scm_print_struct (SCM exp
, SCM port
, scm_print_state
*pstate
)
749 if (SCM_NFALSEP (scm_procedure_p (SCM_STRUCT_PRINTER (exp
))))
750 scm_printer_apply (SCM_STRUCT_PRINTER (exp
), exp
, port
, pstate
);
753 SCM vtable
= SCM_STRUCT_VTABLE (exp
);
754 SCM name
= scm_struct_vtable_name (vtable
);
755 scm_puts ("#<", port
);
756 if (SCM_NFALSEP (name
))
757 scm_display (name
, port
);
759 scm_puts ("struct", port
);
760 scm_putc (' ', port
);
761 scm_intprint ((int) vtable
, 16, port
);
762 scm_putc (':', port
);
763 scm_intprint ((int)exp
, 16, port
);
764 scm_putc ('>', port
);
772 = scm_permanent_object (scm_make_weak_key_hash_table (SCM_MAKINUM (31)));
773 required_vtable_fields
= SCM_CAR (scm_intern_obarray ("pruosrpw", sizeof ("pruosrpw") - 1, SCM_BOOL_F
));
774 scm_permanent_object (required_vtable_fields
);
775 scm_sysintern ("vtable-index-layout", SCM_MAKINUM (scm_vtable_index_layout
));
776 scm_sysintern ("vtable-index-vtable", SCM_MAKINUM (scm_vtable_index_vtable
));
777 scm_sysintern ("vtable-index-printer", SCM_MAKINUM (scm_vtable_index_printer
));
778 scm_sysintern ("vtable-offset-user", SCM_MAKINUM (scm_vtable_offset_user
));