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 */
65 static SCM required_vtable_fields
= SCM_BOOL_F
;
69 SCM_DEFINE (scm_make_struct_layout
, "make-struct-layout", 1, 0, 0,
71 "Return a new structure layout object.\n\n"
72 "@var{fields} must be a read-only 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 "fields that should point 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
83 SCM_VALIDATE_ROSTRING (1,fields
);
89 len
= SCM_ROLENGTH (fields
);
90 field_desc
= SCM_ROCHARS (fields
);
91 SCM_ASSERT (!(len
& 1), fields
, "odd length field specification", FUNC_NAME
);
93 for (x
= 0; x
< len
; x
+= 2)
95 switch (field_desc
[x
])
106 SCM_ASSERT (0, SCM_MAKE_CHAR (field_desc
[x
]) , "unrecognized field type", FUNC_NAME
);
109 switch (field_desc
[x
+ 1])
112 SCM_ASSERT (field_desc
[x
] != 's', SCM_MAKE_CHAR (field_desc
[x
+ 1]),
113 "self fields not writable", FUNC_NAME
);
121 SCM_ASSERT (field_desc
[x
] != 's', SCM_MAKE_CHAR (field_desc
[x
+ 1]),
122 "self fields not allowed in tail array",
124 SCM_ASSERT (x
== len
- 2, SCM_MAKE_CHAR (field_desc
[x
+ 1]),
125 "tail array field must be last field in layout",
129 SCM_ASSERT (0, SCM_MAKE_CHAR (field_desc
[x
]) , "unrecognized ref specification", FUNC_NAME
);
132 if (field_desc
[x
] == 'd')
134 SCM_ASSERT (field_desc
[x
+ 2] == '-', SCM_MAKINUM (x
/ 2), "missing dash field", FUNC_NAME
);
140 new_sym
= SCM_CAR (scm_intern_obarray (field_desc
, len
, SCM_BOOL_F
));
142 return scm_return_first (new_sym
, fields
);
151 scm_struct_init (SCM handle
, int tail_elts
, SCM inits
)
155 unsigned char * fields_desc
;
156 unsigned char prot
= 0;
161 layout
= SCM_STRUCT_LAYOUT (handle
);
162 data
= SCM_STRUCT_DATA (handle
);
163 fields_desc
= (unsigned char *) SCM_CHARS (layout
) - 2;
164 n_fields
= SCM_LENGTH (layout
) / 2;
165 mem
= SCM_STRUCT_DATA (handle
);
171 prot
= fields_desc
[1];
172 if (SCM_LAYOUT_TAILP (prot
))
175 prot
= prot
== 'R' ? 'r' : prot
== 'W' ? 'w' : 'o';
176 *mem
++ = SCM_PACK (tail_elts
);
177 n_fields
+= tail_elts
- 1;
183 switch (*fields_desc
)
187 if ((prot
!= 'r' && prot
!= 'w') || inits
== SCM_EOL
)
191 *mem
= scm_num2long (SCM_CAR (inits
), SCM_ARGn
, "scm_struct_init");
192 inits
= SCM_CDR (inits
);
198 if ((prot
!= 'r' && prot
!= 'w') || inits
== SCM_EOL
)
202 *mem
= SCM_PACK (scm_num2ulong (SCM_CAR (inits
),
205 inits
= SCM_CDR (inits
);
210 if ((prot
!= 'r' && prot
!= 'w') || inits
== SCM_EOL
)
214 *mem
= SCM_CAR (inits
);
215 inits
= SCM_CDR (inits
);
222 if ((prot
!= 'r' && prot
!= 'w') || inits
== SCM_EOL
)
223 *((double *)mem
) = 0.0;
226 *mem
= scm_num2dbl (SCM_CAR (inits
), "scm_struct_init");
227 inits
= SCM_CDR (inits
);
244 SCM_DEFINE (scm_struct_p
, "struct?", 1, 0, 0,
246 "Return #t iff @var{obj} is a structure object, else #f.")
247 #define FUNC_NAME s_scm_struct_p
249 return SCM_BOOL(SCM_STRUCTP (x
));
253 SCM_DEFINE (scm_struct_vtable_p
, "struct-vtable?", 1, 0, 0,
255 "Return #t iff obj is a vtable structure.")
256 #define FUNC_NAME s_scm_struct_vtable_p
264 if (!SCM_STRUCTP (x
))
267 layout
= SCM_STRUCT_LAYOUT (x
);
269 if (SCM_LENGTH (layout
) < SCM_LENGTH (required_vtable_fields
))
272 if (strncmp (SCM_CHARS (layout
), SCM_CHARS (required_vtable_fields
),
273 SCM_LENGTH (required_vtable_fields
)))
276 mem
= SCM_STRUCT_DATA (x
);
281 if (SCM_IMP (mem
[0]))
284 return SCM_BOOL(SCM_SYMBOLP (mem
[0]));
289 /* All struct data must be allocated at an address whose bottom three
290 bits are zero. This is because the tag for a struct lives in the
291 bottom three bits of the struct's car, and the upper bits point to
292 the data of its vtable, which is a struct itself. Thus, if the
293 address of that data doesn't end in three zeros, tagging it will
296 This function allocates a block of memory, and returns a pointer at
297 least scm_struct_n_extra_words words into the block. Furthermore,
298 it guarantees that that pointer's least three significant bits are
301 The argument n_words should be the number of words that should
302 appear after the returned address. (That is, it shouldn't include
303 scm_struct_n_extra_words.)
305 This function initializes the following fields of the struct:
307 scm_struct_i_ptr --- the actual start of the block of memory; the
308 address you should pass to 'free' to dispose of the block.
309 This field allows us to both guarantee that the returned
310 address is divisible by eight, and allow the GC to free the
313 scm_struct_i_n_words --- the number of words allocated to the
314 block, including the extra fields. This is used by the GC.
320 scm_alloc_struct (int n_words
, int n_extra
, char *who
)
322 int size
= sizeof (SCM
) * (n_words
+ n_extra
) + 7;
323 SCM
*block
= (SCM
*) scm_must_malloc (size
, who
);
325 /* Adjust the pointer to hide the extra words. */
326 SCM
*p
= block
+ n_extra
;
328 /* Adjust it even further so it's aligned on an eight-byte boundary. */
329 p
= (SCM
*) (((scm_bits_t
) SCM_UNPACK (p
) + 7) & ~7);
331 /* Initialize a few fields as described above. */
332 p
[scm_struct_i_free
] = (SCM
) scm_struct_free_standard
;
333 p
[scm_struct_i_ptr
] = (SCM
) block
;
334 p
[scm_struct_i_n_words
] = (SCM
) n_words
;
335 p
[scm_struct_i_flags
] = 0;
341 scm_struct_free_0 (SCM
*vtable
, SCM
*data
)
347 scm_struct_free_light (SCM
*vtable
, SCM
*data
)
350 return SCM_UNPACK (vtable
[scm_struct_i_size
]) & ~SCM_STRUCTF_MASK
;
354 scm_struct_free_standard (SCM
*vtable
, SCM
*data
)
356 size_t n
= ((SCM_UNPACK (data
[scm_struct_i_n_words
]) + scm_struct_n_extra_words
)
358 free ((void *) data
[scm_struct_i_ptr
]);
363 scm_struct_free_entity (SCM
*vtable
, SCM
*data
)
365 size_t n
= (SCM_UNPACK(data
[scm_struct_i_n_words
] + scm_struct_entity_n_extra_words
)
367 free ((void *) data
[scm_struct_i_ptr
]);
371 SCM_DEFINE (scm_make_struct
, "make-struct", 2, 0, 1,
372 (SCM vtable
, SCM tail_array_size
, SCM init
),
373 "Create a new structure.\n\n"
374 "@var{type} must be a vtable structure (@xref{Vtables}).\n\n"
375 "@var{tail-elts} must be a non-negative integer. If the layout\n"
376 "specification indicated by @var{type} includes a tail-array,\n"
377 "this is the number of elements allocated to that array.\n\n"
378 "The @var{inits} are optional arguments describing how successive fields\n"
379 "of the structure should be initialized. Only fields with protection 'r'\n"
380 "or 'w' can be initialized -- fields of protection 's' are automatically\n"
381 "initialized to point to the new structure itself; fields of protection 'o'\n"
382 "can not be initialized by Scheme programs.")
383 #define FUNC_NAME s_scm_make_struct
391 SCM_VALIDATE_VTABLE (1,vtable
);
392 SCM_VALIDATE_INUM (2,tail_array_size
);
394 layout
= SCM_STRUCT_DATA (vtable
)[scm_vtable_index_layout
];
395 basic_size
= SCM_LENGTH (layout
) / 2;
396 tail_elts
= SCM_INUM (tail_array_size
);
397 SCM_NEWCELL (handle
);
399 if (SCM_UNPACK (SCM_STRUCT_DATA (vtable
)[scm_struct_i_flags
]) & SCM_STRUCTF_ENTITY
)
401 data
= scm_alloc_struct (basic_size
+ tail_elts
,
402 scm_struct_entity_n_extra_words
,
404 data
[scm_struct_i_procedure
] = SCM_BOOL_F
;
405 data
[scm_struct_i_setter
] = SCM_BOOL_F
;
408 data
= scm_alloc_struct (basic_size
+ tail_elts
,
409 scm_struct_n_extra_words
,
411 SCM_SETCDR (handle
, data
);
412 SCM_SETCAR (handle
, ((SCM
)SCM_STRUCT_DATA (vtable
)) + scm_tc3_cons_gloc
);
413 scm_struct_init (handle
, tail_elts
, init
);
421 SCM_DEFINE (scm_make_vtable_vtable
, "make-vtable-vtable", 2, 0, 1,
422 (SCM extra_fields
, SCM tail_array_size
, SCM init
),
423 "Return a new, self-describing vtable structure.\n\n"
424 "@var{new-fields} is a layout specification describing fields\n"
425 "of the resulting structure beginning at the position bound to\n"
426 "@code{vtable-offset-user}.\n\n"
427 "@var{tail-size} specifies the size of the tail-array (if any) of\n"
429 "@var{inits} initializes the fields of the vtable. Minimally, one\n"
430 "initializer must be provided: the layout specification for instances\n"
431 "of the type this vtable will describe. If a second initializer is\n"
432 "provided, it will be interpreted as a print call-back function.\n\n"
434 ";;; loading ,a...\n"
436 " (make-vtable-vtable (make-struct-layout (quote pw))\n"
441 "(struct-vtable? x)\n"
443 "(eq? x (struct-vtable x))\n"
445 "(struct-ref x vtable-offset-user)\n"
448 "@result{} pruosrpwpw\n\n\n"
452 " (make-struct-layout (quote pwpwpw))\n"
456 "(struct-vtable? y)\n"
460 "(eq? x (struct-vtable y))\n"
464 "(struct-ref y vtable-offset-user)\n"
465 "@result{} bar\n\n\n"
466 "(define z (make-struct y 0 'a 'b 'c))\n\n"
469 "(struct-vtable? z)\n"
471 "(eq? y (struct-vtable z))\n"
473 "(map (lambda (n) (struct-ref z n)) '(0 1 2))\n"
474 "@result{} (a b c)\n"
477 #define FUNC_NAME s_scm_make_vtable_vtable
486 SCM_VALIDATE_ROSTRING (1,extra_fields
);
487 SCM_VALIDATE_INUM (2,tail_array_size
);
489 fields
= scm_string_append (scm_listify (required_vtable_fields
,
492 layout
= scm_make_struct_layout (fields
);
493 basic_size
= SCM_LENGTH (layout
) / 2;
494 tail_elts
= SCM_INUM (tail_array_size
);
495 SCM_NEWCELL (handle
);
497 data
= scm_alloc_struct (basic_size
+ tail_elts
,
498 scm_struct_n_extra_words
,
499 "make-vtable-vtable");
500 SCM_SETCDR (handle
, data
);
501 SCM_SETCAR (handle
, ((SCM
)data
) + scm_tc3_cons_gloc
);
502 SCM_STRUCT_LAYOUT (handle
) = layout
;
503 scm_struct_init (handle
, tail_elts
, scm_cons (layout
, init
));
512 SCM_DEFINE (scm_struct_ref
, "struct-ref", 2, 0, 0,
513 (SCM handle
, SCM pos
),
514 "@deffnx primitive struct-set! struct n value\n"
515 "Access (or modify) the @var{n}th field of @var{struct}.\n\n"
516 "If the field is of type 'p', then it can be set to an arbitrary value.\n\n"
517 "If the field is of type 'u', then it can only be set to a non-negative\n"
518 "integer value small enough to fit in one machine word.")
519 #define FUNC_NAME s_scm_struct_ref
521 SCM answer
= SCM_UNDEFINED
;
526 unsigned char * fields_desc
;
527 unsigned char field_type
= 0;
530 SCM_VALIDATE_STRUCT (1,handle
);
531 SCM_VALIDATE_INUM (2,pos
);
533 layout
= SCM_STRUCT_LAYOUT (handle
);
534 data
= SCM_STRUCT_DATA (handle
);
537 fields_desc
= (unsigned char *) SCM_CHARS (layout
);
538 n_fields
= SCM_UNPACK (data
[scm_struct_i_n_words
]);
540 SCM_ASSERT_RANGE(1,pos
, p
< n_fields
);
542 if (p
* 2 < SCM_LENGTH (layout
))
545 field_type
= fields_desc
[p
* 2];
546 ref
= fields_desc
[p
* 2 + 1];
547 if ((ref
!= 'r') && (ref
!= 'w'))
549 if ((ref
== 'R') || (ref
== 'W'))
552 SCM_ASSERT (0, pos
, "ref denied", FUNC_NAME
);
555 else if (fields_desc
[SCM_LENGTH (layout
) - 1] != 'O')
556 field_type
= fields_desc
[SCM_LENGTH (layout
) - 2];
559 SCM_ASSERT (0, pos
, "ref denied", FUNC_NAME
);
566 answer
= scm_ulong2num (SCM_UNPACK (data
[p
]));
571 answer
= scm_long2num (data
[p
]);
575 answer
= scm_makdbl (*((double *)&(data
[p
])), 0.0);
586 SCM_ASSERT (0, SCM_MAKE_CHAR (field_type
), "unrecognized field type", FUNC_NAME
);
595 SCM_DEFINE (scm_struct_set_x
, "struct-set!", 3, 0, 0,
596 (SCM handle
, SCM pos
, SCM val
),
598 #define FUNC_NAME s_scm_struct_set_x
604 unsigned char * fields_desc
;
605 unsigned char field_type
= 0;
607 SCM_VALIDATE_STRUCT (1,handle
);
608 SCM_VALIDATE_INUM (2,pos
);
610 layout
= SCM_STRUCT_LAYOUT (handle
);
611 data
= SCM_STRUCT_DATA (handle
);
614 fields_desc
= (unsigned char *)SCM_CHARS (layout
);
615 n_fields
= SCM_UNPACK (data
[scm_struct_i_n_words
]);
617 SCM_ASSERT_RANGE (1,pos
, p
< n_fields
);
619 if (p
* 2 < SCM_LENGTH (layout
))
622 field_type
= fields_desc
[p
* 2];
623 set_x
= fields_desc
[p
* 2 + 1];
625 SCM_ASSERT (0, pos
, "set_x denied", FUNC_NAME
);
627 else if (fields_desc
[SCM_LENGTH (layout
) - 1] == 'W')
628 field_type
= fields_desc
[SCM_LENGTH (layout
) - 2];
631 SCM_ASSERT (0, pos
, "set_x denied", FUNC_NAME
);
638 data
[p
] = SCM_PACK (SCM_NUM2ULONG (3, val
));
643 data
[p
] = SCM_NUM2LONG (3,val
);
647 *((double *)&(data
[p
])) = scm_num2dbl (val
, (char *)SCM_ARG3
);
656 SCM_ASSERT (0, SCM_MAKE_CHAR (field_type
), "self fields immutable", FUNC_NAME
);
660 SCM_ASSERT (0, SCM_MAKE_CHAR (field_type
), "unrecognized field type", FUNC_NAME
);
669 SCM_DEFINE (scm_struct_vtable
, "struct-vtable", 1, 0, 0,
671 "Return the vtable structure that describes the type of @var{struct}.")
672 #define FUNC_NAME s_scm_struct_vtable
674 SCM_VALIDATE_STRUCT (1,handle
);
675 return SCM_STRUCT_VTABLE (handle
);
680 SCM_DEFINE (scm_struct_vtable_tag
, "struct-vtable-tag", 1, 0, 0,
683 #define FUNC_NAME s_scm_struct_vtable_tag
685 SCM_VALIDATE_VTABLE (1,handle
);
686 return scm_long2num ((long) SCM_STRUCT_DATA (handle
) >> 3);
690 /* {Associating names and classes with vtables}
692 * The name of a vtable should probably be stored as a slot. This is
693 * a backward compatible solution until agreement has been achieved on
694 * how to associate names with vtables.
698 scm_struct_ihashq (SCM obj
, unsigned int n
)
700 /* The length of the hash table should be a relative prime it's not
701 necessary to shift down the address. */
702 return SCM_UNPACK (obj
) % n
;
706 scm_struct_create_handle (SCM obj
)
708 SCM handle
= scm_hash_fn_create_handle_x (scm_struct_table
,
714 if (SCM_FALSEP (SCM_CDR (handle
)))
715 SCM_SETCDR (handle
, scm_cons (SCM_BOOL_F
, SCM_BOOL_F
));
719 SCM_DEFINE (scm_struct_vtable_name
, "struct-vtable-name", 1, 0, 0,
722 #define FUNC_NAME s_scm_struct_vtable_name
724 SCM_VALIDATE_VTABLE (1,vtable
);
725 return SCM_STRUCT_TABLE_NAME (SCM_CDR (scm_struct_create_handle (vtable
)));
729 SCM_DEFINE (scm_set_struct_vtable_name_x
, "set-struct-vtable-name!", 2, 0, 0,
730 (SCM vtable
, SCM name
),
732 #define FUNC_NAME s_scm_set_struct_vtable_name_x
734 SCM_VALIDATE_VTABLE (1,vtable
);
735 SCM_VALIDATE_SYMBOL (2,name
);
736 SCM_SET_STRUCT_TABLE_NAME (SCM_CDR (scm_struct_create_handle (vtable
)),
738 return SCM_UNSPECIFIED
;
746 scm_print_struct (SCM exp
, SCM port
, scm_print_state
*pstate
)
748 if (SCM_NFALSEP (scm_procedure_p (SCM_STRUCT_PRINTER (exp
))))
749 scm_printer_apply (SCM_STRUCT_PRINTER (exp
), exp
, port
, pstate
);
752 SCM vtable
= SCM_STRUCT_VTABLE (exp
);
753 SCM name
= scm_struct_vtable_name (vtable
);
754 scm_puts ("#<", port
);
755 if (SCM_NFALSEP (name
))
756 scm_display (name
, port
);
758 scm_puts ("struct", port
);
759 scm_putc (' ', port
);
760 scm_intprint ((int) vtable
, 16, port
);
761 scm_putc (':', port
);
762 scm_intprint ((int)exp
, 16, port
);
763 scm_putc ('>', port
);
771 = scm_permanent_object (scm_make_weak_key_hash_table (SCM_MAKINUM (31)));
772 required_vtable_fields
= SCM_CAR (scm_intern_obarray ("pruosrpw", sizeof ("pruosrpw") - 1, SCM_BOOL_F
));
773 scm_permanent_object (required_vtable_fields
);
774 scm_sysintern ("vtable-index-layout", SCM_MAKINUM (scm_vtable_index_layout
));
775 scm_sysintern ("vtable-index-vtable", SCM_MAKINUM (scm_vtable_index_vtable
));
776 scm_sysintern ("vtable-index-printer", SCM_MAKINUM (scm_vtable_index_printer
));
777 scm_sysintern ("vtable-offset-user", SCM_MAKINUM (scm_vtable_offset_user
));