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

belatedly adding type checks on read/write/display

Browse source
This commit is contained in:
Alex Shinn 2009-12-29 20:12:09 +09:00
parent 351bf36ecf
commit e2d7291269
2 changed files with 31 additions and 16 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

2
eval.c
View file

@ -2025,7 +2025,7 @@ static sexp sexp_open_output_file (sexp ctx, sexp path) {
if (! out) if (! out)
return return
sexp_user_exception(ctx, SEXP_FALSE, "couldn't open output file", path); sexp_user_exception(ctx, SEXP_FALSE, "couldn't open output file", path);
return sexp_make_input_port(ctx, out, path); return sexp_make_output_port(ctx, out, path);
} }
static sexp sexp_close_port (sexp ctx, sexp port) { static sexp sexp_close_port (sexp ctx, sexp port) {

45
sexp.c
View file

@ -1017,7 +1017,7 @@ sexp sexp_make_output_port (sexp ctx, FILE* out, sexp name) {
return p; return p;
} }
sexp sexp_write (sexp ctx, sexp obj, sexp out) { sexp sexp_write_one (sexp ctx, sexp obj, sexp out) {
#if SEXP_USE_HUFF_SYMS #if SEXP_USE_HUFF_SYMS
unsigned long res, c; unsigned long res, c;
#endif #endif
@ -1033,14 +1033,14 @@ sexp sexp_write (sexp ctx, sexp obj, sexp out) {
switch (sexp_pointer_tag(obj)) { switch (sexp_pointer_tag(obj)) {
case SEXP_PAIR: case SEXP_PAIR:
sexp_write_char(ctx, '(', out); sexp_write_char(ctx, '(', out);
sexp_write(ctx, sexp_car(obj), out); sexp_write_one(ctx, sexp_car(obj), out);
for (x=sexp_cdr(obj); sexp_pairp(x); x=sexp_cdr(x)) { for (x=sexp_cdr(obj); sexp_pairp(x); x=sexp_cdr(x)) {
sexp_write_char(ctx, ' ', out); sexp_write_char(ctx, ' ', out);
sexp_write(ctx, sexp_car(x), out); sexp_write_one(ctx, sexp_car(x), out);
} }
if (! sexp_nullp(x)) { if (! sexp_nullp(x)) {
sexp_write_string(ctx, " . ", out); sexp_write_string(ctx, " . ", out);
sexp_write(ctx, x, out); sexp_write_one(ctx, x, out);
} }
sexp_write_char(ctx, ')', out); sexp_write_char(ctx, ')', out);
break; break;
@ -1051,10 +1051,10 @@ sexp sexp_write (sexp ctx, sexp obj, sexp out) {
sexp_write_string(ctx, "#()", out); sexp_write_string(ctx, "#()", out);
} else { } else {
sexp_write_string(ctx, "#(", out); sexp_write_string(ctx, "#(", out);
sexp_write(ctx, elts[0], out); sexp_write_one(ctx, elts[0], out);
for (i=1; i<len; i++) { for (i=1; i<len; i++) {
sexp_write_char(ctx, ' ', out); sexp_write_char(ctx, ' ', out);
sexp_write(ctx, elts[i], out); sexp_write_one(ctx, elts[i], out);
} }
sexp_write_char(ctx, ')', out); sexp_write_char(ctx, ')', out);
} }
@ -1079,7 +1079,7 @@ sexp sexp_write (sexp ctx, sexp obj, sexp out) {
#endif #endif
case SEXP_PROCEDURE: case SEXP_PROCEDURE:
sexp_write_string(ctx, "#<procedure: ", out); sexp_write_string(ctx, "#<procedure: ", out);
sexp_write(ctx, sexp_bytecode_name(sexp_procedure_code(obj)), out); sexp_write_one(ctx, sexp_bytecode_name(sexp_procedure_code(obj)), out);
sexp_write_string(ctx, ">", out); sexp_write_string(ctx, ">", out);
break; break;
case SEXP_STRING: case SEXP_STRING:
@ -1192,14 +1192,24 @@ sexp sexp_write (sexp ctx, sexp obj, sexp out) {
return SEXP_VOID; return SEXP_VOID;
} }
sexp sexp_write (sexp ctx, sexp obj, sexp out) {
if (! sexp_oportp(out))
return sexp_type_exception(ctx, "write: not an output-port", out);
else
return sexp_write_one(ctx, obj, out);
}
sexp sexp_display (sexp ctx, sexp obj, sexp out) { sexp sexp_display (sexp ctx, sexp obj, sexp out) {
if (sexp_stringp(obj)) sexp res=SEXP_VOID;
if (! sexp_oportp(out))
res = sexp_type_exception(ctx, "display: not an output-port", out);
else if (sexp_stringp(obj))
sexp_write_string(ctx, sexp_string_data(obj), out); sexp_write_string(ctx, sexp_string_data(obj), out);
else if (sexp_charp(obj)) else if (sexp_charp(obj))
sexp_write_char(ctx, sexp_unbox_character(obj), out); sexp_write_char(ctx, sexp_unbox_character(obj), out);
else else
sexp_write(ctx, obj, out); res = sexp_write_one(ctx, obj, out);
return SEXP_VOID; return res;
} }
sexp sexp_flush_output (sexp ctx, sexp out) { sexp sexp_flush_output (sexp ctx, sexp out) {
@ -1608,11 +1618,15 @@ sexp sexp_read_raw (sexp ctx, sexp in) {
} }
sexp sexp_read (sexp ctx, sexp in) { sexp sexp_read (sexp ctx, sexp in) {
sexp res = sexp_read_raw(ctx, in); sexp res;
if (sexp_iportp(in))
res = sexp_read_raw(ctx, in);
else
res = sexp_type_exception(ctx, "read: not an input-port", in);
if (res == SEXP_CLOSE) if (res == SEXP_CLOSE)
return sexp_read_error(ctx, "too many ')'s", SEXP_NULL, in); res = sexp_read_error(ctx, "too many ')'s", SEXP_NULL, in);
if (res == SEXP_RAWDOT) if (res == SEXP_RAWDOT)
return sexp_read_error(ctx, "unexpected '.'", SEXP_NULL, in); res = sexp_read_error(ctx, "unexpected '.'", SEXP_NULL, in);
return res; return res;
} }
@ -1632,8 +1646,9 @@ sexp sexp_write_to_string(sexp ctx, sexp obj) {
sexp_gc_var1(out); sexp_gc_var1(out);
sexp_gc_preserve1(ctx, out); sexp_gc_preserve1(ctx, out);
out = sexp_make_output_string_port(ctx); out = sexp_make_output_string_port(ctx);
sexp_write(ctx, obj, out); str = sexp_write(ctx, obj, out);
str = sexp_get_output_string(ctx, out); if (! sexp_exceptionp(str))
str = sexp_get_output_string(ctx, out);
sexp_gc_release1(ctx); sexp_gc_release1(ctx);
return str; return str;
} }