Fcalva/chibi-scheme
1
0
Fork 0
mirror of https://github.com/ashinn/chibi-scheme.git synced 2025-07-03 19:26:36 +02:00
Code Issues Projects Releases Packages Wiki Activity Actions 1

For FFI setters/getters, don't set the type field length which has different assumptions.

Browse source 
Check the existence and length of the corresponding vector instead.
This commit is contained in:
Alex Shinn 2015-01-03 23:43:02 -05:00
parent 0737094107
commit 8dedc36609
2 changed files with 12 additions and 8 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

2
tools/chibi-ffi
View file

@ -1591,8 +1591,6 @@
(if (pair? (struct-fields type))
(let ((len (make-integer (length (struct-fields type)))))
(cat " sexp_type_slots(" (type-id-name name) ") = SEXP_NULL;\n"
" sexp_type_field_len_base(" (type-id-name name) ")"
" = " (length (struct-fields type)) ";\n"
(lambda ()
(do ((ls (reverse (struct-fields type)) (cdr ls)))
((not (pair? ls)))

18
vm.c
View file

@ -1537,16 +1537,19 @@ sexp sexp_apply (sexp ctx, sexp proc, sexp args) {
if (sexp_car(tmp1) == _ARG3) { _ARG3 = sexp_make_fixnum(i); break; }
if (! sexp_fixnump(_ARG3))
sexp_raise("slotn-ref: not an integer", sexp_list1(ctx, _ARG3));
if (sexp_unbox_fixnum(_ARG3) < 0 || sexp_unbox_fixnum(_ARG3) >= sexp_type_field_len_base(_ARG1))
sexp_raise("slotn-ref: slot out of bounds", sexp_list2(ctx, _ARG3, sexp_make_fixnum(sexp_type_field_len_base(_ARG1))));
if (sexp_vectorp(sexp_type_getters(_ARG1))) {
if (sexp_unbox_fixnum(_ARG3) < 0 || sexp_unbox_fixnum(_ARG3) >= sexp_vector_length(sexp_type_getters(_ARG1)))
sexp_raise("slotn-ref: slot out of bounds", sexp_list2(ctx, _ARG3, sexp_make_fixnum(sexp_type_field_len_base(_ARG1))));
tmp1 = sexp_vector_ref(sexp_type_getters(_ARG1), _ARG3);
if (sexp_opcodep(tmp1))
_ARG3 = ((sexp_proc2)sexp_opcode_func(tmp1))(ctx, tmp1, 1, _ARG2);
else
sexp_raise("slotn-ref: no getter defined", sexp_list1(ctx, _ARG3));
} else
} else {
if (sexp_unbox_fixnum(_ARG3) < 0 || sexp_unbox_fixnum(_ARG3) >= sexp_type_field_len_base(_ARG1))
sexp_raise("slotn-ref: slot out of bounds", sexp_list2(ctx, _ARG3, sexp_make_fixnum(sexp_type_field_len_base(_ARG1))));
_ARG3 = sexp_slot_ref(_ARG2, sexp_unbox_fixnum(_ARG3));
}
top-=2;
if (!_ARG1) _ARG1 = SEXP_VOID;
else sexp_check_exception();
@ -1563,16 +1566,19 @@ sexp sexp_apply (sexp ctx, sexp proc, sexp args) {
if (sexp_car(tmp1) == _ARG3) { _ARG3 = sexp_make_fixnum(i); break; }
if (! sexp_fixnump(_ARG3))
sexp_raise("slotn-set!: not an integer", sexp_list1(ctx, _ARG3));
if (sexp_unbox_fixnum(_ARG3) < 0 || sexp_unbox_fixnum(_ARG3) >= sexp_type_field_len_base(_ARG1))
sexp_raise("slotn-set!: slot out of bounds", sexp_list2(ctx, _ARG3, sexp_make_fixnum(sexp_type_field_len_base(_ARG1))));
if (sexp_vectorp(sexp_type_setters(_ARG1))) {
if (sexp_unbox_fixnum(_ARG3) < 0 || sexp_unbox_fixnum(_ARG3) >= sexp_vector_length(sexp_type_setters(_ARG1)))
sexp_raise("slotn-set!: slot out of bounds", sexp_list2(ctx, _ARG3, sexp_make_fixnum(sexp_type_field_len_base(_ARG1))));
tmp1 = sexp_vector_ref(sexp_type_setters(_ARG1), _ARG3);
if (sexp_opcodep(tmp1))
_ARG4 = ((sexp_proc3)sexp_opcode_func(tmp1))(ctx, tmp1, 2, _ARG2, _ARG4);
else
sexp_raise("slotn-set!: no setter defined", sexp_list1(ctx, _ARG3));
} else
} else {
if (sexp_unbox_fixnum(_ARG3) < 0 || sexp_unbox_fixnum(_ARG3) >= sexp_type_field_len_base(_ARG1))
sexp_raise("slotn-set!: slot out of bounds", sexp_list2(ctx, _ARG3, sexp_make_fixnum(sexp_type_field_len_base(_ARG1))));
sexp_slot_set(_ARG2, sexp_unbox_fixnum(_ARG3), _ARG4);
}
top-=4;
sexp_check_exception();
break;