Fcalva/chibi-scheme
1
0
Fork 0
mirror of https://github.com/ashinn/chibi-scheme.git synced 2025-05-20 14:19:18 +02:00
Code Issues Projects Releases Packages Wiki Activity Actions

better type checking in the VM

Browse source 
Fixes http://code.google.com/p/chibi-scheme/issues/detail?id=5
Some non-opcode primitive functions may still need type checking.
This commit is contained in:
Alex Shinn 2009-11-02 23:52:19 +09:00
parent c4625e1c86
commit 44d0156c80
1 changed files with 42 additions and 0 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

42
eval.c
View file

@ -1442,6 +1442,11 @@ sexp sexp_vm (sexp ctx, sexp proc) {
case OP_VECTOR_REF: case OP_VECTOR_REF:
if (! sexp_vectorp(_ARG1)) if (! sexp_vectorp(_ARG1))
sexp_raise("vector-ref: not a vector", sexp_list1(ctx, _ARG1)); sexp_raise("vector-ref: not a vector", sexp_list1(ctx, _ARG1));
else if (! sexp_fixnump(_ARG2))
sexp_raise("vector-ref: not an integer", sexp_list1(ctx, _ARG2));
i = sexp_unbox_fixnum(_ARG2);
if ((i < 0) || (i >= sexp_vector_length(_ARG1)))
sexp_raise("vector-ref: index out of range", sexp_list2(ctx, _ARG1, _ARG2));
_ARG2 = sexp_vector_ref(_ARG1, _ARG2); _ARG2 = sexp_vector_ref(_ARG1, _ARG2);
top--; top--;
break; break;
@ -1450,14 +1455,30 @@ sexp sexp_vm (sexp ctx, sexp proc) {
sexp_raise("vector-set!: not a vector", sexp_list1(ctx, _ARG1)); sexp_raise("vector-set!: not a vector", sexp_list1(ctx, _ARG1));
else if (sexp_immutablep(_ARG1)) else if (sexp_immutablep(_ARG1))
sexp_raise("vector-set!: immutable vector", sexp_list1(ctx, _ARG1)); sexp_raise("vector-set!: immutable vector", sexp_list1(ctx, _ARG1));
else if (! sexp_fixnump(_ARG2))
sexp_raise("vector-set!: not an integer", sexp_list1(ctx, _ARG2));
i = sexp_unbox_fixnum(_ARG2);
if ((i < 0) || (i >= sexp_vector_length(_ARG1)))
sexp_raise("vector-set!: index out of range", sexp_list2(ctx, _ARG1, _ARG2));
sexp_vector_set(_ARG1, _ARG2, _ARG3); sexp_vector_set(_ARG1, _ARG2, _ARG3);
_ARG3 = SEXP_VOID; _ARG3 = SEXP_VOID;
top-=2; top-=2;
break; break;
case OP_VECTOR_LENGTH: case OP_VECTOR_LENGTH:
if (! sexp_vectorp(_ARG1))
sexp_raise("vector-length: not a vector", sexp_list1(ctx, _ARG1));
_ARG1 = sexp_make_fixnum(sexp_vector_length(_ARG1)); _ARG1 = sexp_make_fixnum(sexp_vector_length(_ARG1));
break; break;
case OP_STRING_REF: case OP_STRING_REF:
if (! sexp_stringp(_ARG1))
sexp_raise("string-ref: not a string", sexp_list1(ctx, _ARG1));
else if (sexp_immutablep(_ARG1))
sexp_raise("string-ref: immutable string", sexp_list1(ctx, _ARG1));
else if (! sexp_fixnump(_ARG2))
sexp_raise("string-ref: not an integer", sexp_list1(ctx, _ARG2));
i = sexp_unbox_fixnum(_ARG2);
if ((i < 0) || (i >= sexp_string_length(_ARG1)))
sexp_raise("string-ref: index out of range", sexp_list2(ctx, _ARG1, _ARG2));
_ARG2 = sexp_string_ref(_ARG1, _ARG2); _ARG2 = sexp_string_ref(_ARG1, _ARG2);
top--; top--;
break; break;
@ -1466,11 +1487,20 @@ sexp sexp_vm (sexp ctx, sexp proc) {
sexp_raise("string-set!: not a string", sexp_list1(ctx, _ARG1)); sexp_raise("string-set!: not a string", sexp_list1(ctx, _ARG1));
else if (sexp_immutablep(_ARG1)) else if (sexp_immutablep(_ARG1))
sexp_raise("string-set!: immutable string", sexp_list1(ctx, _ARG1)); sexp_raise("string-set!: immutable string", sexp_list1(ctx, _ARG1));
else if (! sexp_fixnump(_ARG2))
sexp_raise("string-set!: not an integer", sexp_list1(ctx, _ARG2));
else if (! sexp_charp(_ARG3))
sexp_raise("string-set!: not a char", sexp_list1(ctx, _ARG3));
i = sexp_unbox_fixnum(_ARG2);
if ((i < 0) || (i >= sexp_string_length(_ARG1)))
sexp_raise("string-set!: index out of range", sexp_list2(ctx, _ARG1, _ARG2));
sexp_string_set(_ARG1, _ARG2, _ARG3); sexp_string_set(_ARG1, _ARG2, _ARG3);
_ARG3 = SEXP_VOID; _ARG3 = SEXP_VOID;
top-=2; top-=2;
break; break;
case OP_STRING_LENGTH: case OP_STRING_LENGTH:
if (! sexp_stringp(_ARG1))
sexp_raise("string-length: not a string", sexp_list1(ctx, _ARG1));
_ARG1 = sexp_make_fixnum(sexp_string_length(_ARG1)); _ARG1 = sexp_make_fixnum(sexp_string_length(_ARG1));
break; break;
case OP_MAKE_PROCEDURE: case OP_MAKE_PROCEDURE:
@ -1480,6 +1510,8 @@ sexp sexp_vm (sexp ctx, sexp proc) {
break; break;
case OP_MAKE_VECTOR: case OP_MAKE_VECTOR:
sexp_context_top(ctx) = top; sexp_context_top(ctx) = top;
if (! sexp_fixnump(_ARG1))
sexp_raise("make-vector: not an integer", sexp_list1(ctx, _ARG1));
_ARG2 = sexp_make_vector(ctx, _ARG1, _ARG2); _ARG2 = sexp_make_vector(ctx, _ARG1, _ARG2);
top--; top--;
break; break;
@ -1815,15 +1847,23 @@ sexp sexp_vm (sexp ctx, sexp proc) {
} }
break; break;
case OP_CHAR2INT: case OP_CHAR2INT:
if (! sexp_charp(_ARG1))
sexp_raise("char->integer: not a character", sexp_list1(ctx, _ARG1));
_ARG1 = sexp_make_fixnum(sexp_unbox_character(_ARG1)); _ARG1 = sexp_make_fixnum(sexp_unbox_character(_ARG1));
break; break;
case OP_INT2CHAR: case OP_INT2CHAR:
if (! sexp_fixnump(_ARG1))
sexp_raise("integer->char: not an integer", sexp_list1(ctx, _ARG1));
_ARG1 = sexp_make_character(sexp_unbox_fixnum(_ARG1)); _ARG1 = sexp_make_character(sexp_unbox_fixnum(_ARG1));
break; break;
case OP_CHAR_UPCASE: case OP_CHAR_UPCASE:
if (! sexp_charp(_ARG1))
sexp_raise("char-upcase: not a character", sexp_list1(ctx, _ARG1));
_ARG1 = sexp_make_character(toupper(sexp_unbox_character(_ARG1))); _ARG1 = sexp_make_character(toupper(sexp_unbox_character(_ARG1)));
break; break;
case OP_CHAR_DOWNCASE: case OP_CHAR_DOWNCASE:
if (! sexp_charp(_ARG1))
sexp_raise("char-downcase: not a character", sexp_list1(ctx, _ARG1));
_ARG1 = sexp_make_character(tolower(sexp_unbox_character(_ARG1))); _ARG1 = sexp_make_character(tolower(sexp_unbox_character(_ARG1)));
break; break;
case OP_DISPLAY: case OP_DISPLAY:
@ -1845,6 +1885,8 @@ sexp sexp_vm (sexp ctx, sexp proc) {
top--; top--;
break; break;
case OP_WRITE_CHAR: case OP_WRITE_CHAR:
if (! sexp_charp(_ARG1))
sexp_raise("write-char: not a character", sexp_list1(ctx, _ARG1));
sexp_write_char(ctx, sexp_unbox_character(_ARG1), _ARG2); sexp_write_char(ctx, sexp_unbox_character(_ARG1), _ARG2);
_ARG2 = SEXP_VOID; _ARG2 = SEXP_VOID;
top--; top--;