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

simplifying with sexp_assert_type macro

Browse source
This commit is contained in:
Alex Shinn 2010-04-04 10:28:09 +09:00
parent d5ddfe6a92
commit 6e554911e6
3 changed files with 67 additions and 106 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

3
Makefile
View file

@ -92,7 +92,8 @@ COMPILED_LIBS := lib/srfi/27/rand$(SO) lib/srfi/33/bit$(SO) \
lib/srfi/69/hash$(SO) lib/srfi/95/qsort$(SO) lib/srfi/98/env$(SO) \
lib/chibi/ast$(SO) lib/chibi/net$(SO) lib/chibi/filesystem$(SO) \
lib/chibi/process$(SO) lib/chibi/time$(SO) lib/chibi/system$(SO) \
lib/chibi/io/io$(SO) lib/chibi/heap-stats$(SO) lib/chibi/disasm$(SO)
lib/chibi/io/io$(SO) lib/chibi/heap-stats$(SO) lib/chibi/disasm$(SO) \
lib/chibi/x86$(SO)
libs: $(COMPILED_LIBS)

74
eval.c
View file

@ -2026,16 +2026,13 @@ sexp sexp_vm (sexp ctx, sexp proc) {
/************************ library procedures **************************/
static sexp sexp_exception_type_op (sexp ctx sexp_api_params(self, n), sexp exn) {
if (sexp_exceptionp(exn))
sexp_assert_type(ctx, sexp_exceptionp, SEXP_EXCEPTION, exn);
return sexp_exception_kind(exn);
else
return sexp_type_exception(ctx, self, SEXP_EXCEPTION, exn);
}
static sexp sexp_open_input_file_op (sexp ctx sexp_api_params(self, n), sexp path) {
FILE *in;
if (! sexp_stringp(path))
return sexp_type_exception(ctx, self, SEXP_STRING, path);
sexp_assert_type(ctx, sexp_stringp, SEXP_STRING, path);
in = fopen(sexp_string_data(path), "r");
if (! in)
return sexp_user_exception(ctx, self, "couldn't open input file", path);
@ -2044,20 +2041,17 @@ static sexp sexp_open_input_file_op (sexp ctx sexp_api_params(self, n), sexp pat
static sexp sexp_open_output_file_op (sexp ctx sexp_api_params(self, n), sexp path) {
FILE *out;
if (! sexp_stringp(path))
return sexp_type_exception(ctx, self, SEXP_STRING, path);
sexp_assert_type(ctx, sexp_stringp, SEXP_STRING, path);
out = fopen(sexp_string_data(path), "w");
if (! out)
return
sexp_user_exception(ctx, SEXP_FALSE, "couldn't open output file", path);
return sexp_user_exception(ctx, self, "couldn't open output file", path);
return sexp_make_output_port(ctx, out, path);
}
static sexp sexp_close_port_op (sexp ctx sexp_api_params(self, n), sexp port) {
if (! sexp_portp(port))
return sexp_type_exception(ctx, self, SEXP_OPORT, port);
sexp_assert_type(ctx, sexp_portp, SEXP_OPORT, port);
if (! sexp_port_openp(port))
return sexp_user_exception(ctx, SEXP_FALSE, "port already closed", port);
return sexp_user_exception(ctx, self, "port already closed", port);
return sexp_finalize_port(ctx sexp_api_pass(self, n), port);
}
@ -2108,10 +2102,8 @@ sexp sexp_load_op (sexp ctx sexp_api_params(self, n), sexp source, sexp env) {
#endif
sexp tmp, out=SEXP_FALSE;
sexp_gc_var4(ctx2, x, in, res);
if (! sexp_stringp(source))
return sexp_type_exception(ctx, self, SEXP_STRING, source);
if (! sexp_envp(env))
return sexp_type_exception(ctx, self, SEXP_ENV, env);
sexp_assert_type(ctx, sexp_stringp, SEXP_STRING, source);
sexp_assert_type(ctx, sexp_envp, SEXP_ENV, env);
#if SEXP_USE_DL
suffix = sexp_string_data(source)
+ sexp_string_length(source) - strlen(sexp_so_extension);
@ -2172,7 +2164,7 @@ sexp sexp_load_op (sexp ctx sexp_api_params(self, n), sexp source, sexp env) {
d = (double)sexp_unbox_fixnum(z); \
maybe_convert_bignum(z) \
else \
return sexp_type_exception(ctx, self, SEXP_FIXNUM, z); \
return sexp_type_exception(ctx, self, SEXP_NUMBER, z); \
return sexp_make_flonum(ctx, cname(d)); \
}
@ -2197,7 +2189,7 @@ static sexp sexp_sqrt (sexp ctx sexp_api_params(self, n), sexp z) {
d = (double)sexp_unbox_fixnum(z);
maybe_convert_bignum(z) /* XXXX add bignum sqrt */
else
return sexp_type_exception(ctx, self, SEXP_FIXNUM, z);
return sexp_type_exception(ctx, self, SEXP_NUMBER, z);
r = sqrt(d);
if (sexp_fixnump(z) && ((r*r) == (double)sexp_unbox_fixnum(z)))
return sexp_make_fixnum(round(r));
@ -2266,10 +2258,8 @@ static sexp sexp_expt_op (sexp ctx sexp_api_params(self, n), sexp x, sexp e) {
static sexp sexp_string_cmp_op (sexp ctx sexp_api_params(self, n), sexp str1, sexp str2, sexp ci) {
sexp_sint_t len1, len2, len, diff;
if (! sexp_stringp(str1))
return sexp_type_exception(ctx, self, SEXP_STRING, str1);
if (! sexp_stringp(str2))
return sexp_type_exception(ctx, self, SEXP_STRING, str2);
sexp_assert_type(ctx, sexp_stringp, SEXP_STRING, str1);
sexp_assert_type(ctx, sexp_stringp, SEXP_STRING, str2);
len1 = sexp_string_length(str1);
len2 = sexp_string_length(str2);
len = ((len1<len2) ? len1 : len2);
@ -2325,18 +2315,15 @@ sexp sexp_make_opcode (sexp ctx, sexp self, sexp name, sexp op_class, sexp code,
sexp num_args, sexp flags, sexp arg1t, sexp arg2t,
sexp invp, sexp data, sexp data2, sexp_proc1 func) {
sexp res;
if (! sexp_stringp(name))
res = sexp_type_exception(ctx, self, SEXP_STRING, name);
else if ((! sexp_fixnump(op_class)) || (sexp_unbox_fixnum(op_class) <= 0)
sexp_assert_type(ctx, sexp_stringp, SEXP_STRING, name);
sexp_assert_type(ctx, sexp_fixnump, SEXP_FIXNUM, num_args);
sexp_assert_type(ctx, sexp_fixnump, SEXP_FIXNUM, flags);
if ((! sexp_fixnump(op_class)) || (sexp_unbox_fixnum(op_class) <= 0)
|| (sexp_unbox_fixnum(op_class) >= SEXP_OPC_NUM_OP_CLASSES))
res = sexp_user_exception(ctx, self, "make-opcode: bad opcode class", op_class);
res = sexp_xtype_exception(ctx, self, "make-opcode: bad opcode class", op_class);
else if ((! sexp_fixnump(code)) || (sexp_unbox_fixnum(code) <= 0)
|| (sexp_unbox_fixnum(code) >= SEXP_OP_NUM_OPCODES))
res = sexp_user_exception(ctx, self, "make-opcode: bad opcode", code);
else if (! sexp_fixnump(num_args))
res = sexp_type_exception(ctx, self, SEXP_FIXNUM, num_args);
else if (! sexp_fixnump(flags))
res = sexp_type_exception(ctx, self, SEXP_FIXNUM, flags);
res = sexp_xtype_exception(ctx, self, "make-opcode: bad opcode", code);
else {
res = sexp_alloc_type(ctx, opcode, SEXP_OPCODE);
sexp_opcode_class(res) = sexp_unbox_fixnum(op_class);
@ -2403,8 +2390,7 @@ sexp sexp_define_foreign_param (sexp ctx, sexp env, const char *name, int num_ar
#if SEXP_USE_TYPE_DEFS
sexp sexp_make_type_predicate_op (sexp ctx sexp_api_params(self, n), sexp name, sexp type) {
if (! sexp_fixnump(type))
return sexp_type_exception(ctx, self, SEXP_FIXNUM, type);
sexp_assert_type(ctx, sexp_fixnump, SEXP_FIXNUM, type);
return sexp_make_opcode(ctx, self, name, sexp_make_fixnum(SEXP_OPC_TYPE_PREDICATE),
sexp_make_fixnum(SEXP_OP_TYPEP), SEXP_ONE, SEXP_ZERO,
SEXP_ZERO, SEXP_ZERO, SEXP_ZERO, type, NULL, NULL);
@ -2412,8 +2398,7 @@ sexp sexp_make_type_predicate_op (sexp ctx sexp_api_params(self, n), sexp name,
sexp sexp_make_constructor_op (sexp ctx sexp_api_params(self, n), sexp name, sexp type) {
sexp_uint_t type_size;
if (! sexp_fixnump(type))
return sexp_type_exception(ctx, self, SEXP_FIXNUM, type);
sexp_assert_type(ctx, sexp_fixnump, SEXP_FIXNUM, type);
type_size = sexp_type_size_base(sexp_type_by_index(ctx, sexp_unbox_fixnum(type)));
return sexp_make_opcode(ctx, self, name, sexp_make_fixnum(SEXP_OPC_CONSTRUCTOR),
sexp_make_fixnum(SEXP_OP_MAKE), SEXP_ZERO, SEXP_ZERO,
@ -2551,24 +2536,19 @@ sexp sexp_load_module_file (sexp ctx, const char *file, sexp env) {
#if SEXP_USE_MODULES
static sexp sexp_find_module_file_op (sexp ctx sexp_api_params(self, n), sexp file) {
if (! sexp_stringp(file))
return sexp_type_exception(ctx, self, SEXP_STRING, file);
else
sexp_assert_type(ctx, sexp_stringp, SEXP_STRING, file);
return sexp_find_module_file(ctx, sexp_string_data(file));
}
sexp sexp_load_module_file_op (sexp ctx sexp_api_params(self, n), sexp file, sexp env) {
if (! sexp_stringp(file))
return sexp_type_exception(ctx, self, SEXP_STRING, file);
else if (! sexp_envp(env))
return sexp_type_exception(ctx, self, SEXP_ENV, env);
sexp_assert_type(ctx, sexp_stringp, SEXP_STRING, file);
sexp_assert_type(ctx, sexp_envp, SEXP_ENV, env);
return sexp_load_module_file(ctx, sexp_string_data(file), env);
}
#endif
sexp sexp_add_module_directory_op (sexp ctx sexp_api_params(self, n), sexp dir, sexp appendp) {
sexp ls;
if (! sexp_stringp(dir))
return sexp_type_exception(ctx, self, SEXP_STRING, dir);
sexp_assert_type(ctx, sexp_stringp, SEXP_STRING, dir);
if (sexp_truep(appendp)) {
if (sexp_pairp(ls=sexp_global(ctx, SEXP_G_MODULE_PATH))) {
for ( ; sexp_pairp(sexp_cdr(ls)); ls=sexp_cdr(ls))
@ -2749,10 +2729,8 @@ sexp sexp_eval_op (sexp ctx sexp_api_params(self, n), sexp obj, sexp env) {
sexp_sint_t top;
sexp ctx2;
sexp_gc_var2(res, err_handler);
if (! env)
env = sexp_context_env(ctx);
else if (! sexp_envp(env))
return sexp_type_exception(ctx, self, SEXP_ENV, env);
if (! env) env = sexp_context_env(ctx);
sexp_assert_type(ctx, sexp_envp, SEXP_ENV, env);
sexp_gc_preserve2(ctx, res, err_handler);
top = sexp_context_top(ctx);
err_handler = sexp_cdr(sexp_global(ctx, SEXP_G_ERR_HANDLER));

56
sexp.c
View file

@ -135,7 +135,7 @@ sexp sexp_register_type_op (sexp ctx sexp_api_params(self, n), sexp name,
sexp_uint_t i, len, num_types=sexp_context_num_types(ctx),
type_array_size=sexp_context_type_array_size(ctx);
if (num_types >= SEXP_MAXIMUM_TYPES) {
res = sexp_user_exception(ctx, SEXP_FALSE, "register-type: exceeded maximum type limit", name);
res = sexp_user_exception(ctx, self, "register-type: exceeded maximum type limit", name);
} else if (! sexp_stringp(name)) {
res = sexp_type_exception(ctx, self, SEXP_STRING, name);
} else {
@ -535,11 +535,8 @@ sexp sexp_reverse_op (sexp ctx sexp_api_params(self, n), sexp ls) {
sexp sexp_nreverse_op (sexp ctx sexp_api_params(self, n), sexp ls) {
sexp a, b, tmp;
if (ls == SEXP_NULL) {
return ls;
} else if (! sexp_pairp(ls)) {
return sexp_type_exception(ctx, self, SEXP_PAIR, ls);
} else {
if (ls == SEXP_NULL) return ls;
sexp_assert_type(ctx, sexp_pairp, SEXP_PAIR, ls);
b = ls;
a = sexp_cdr(ls);
sexp_cdr(b) = SEXP_NULL;
@ -548,7 +545,6 @@ sexp sexp_nreverse_op (sexp ctx sexp_api_params(self, n), sexp ls) {
sexp_cdr(a) = b;
}
return b;
}
}
sexp sexp_append2_op (sexp ctx sexp_api_params(self, n), sexp a, sexp b) {
@ -651,8 +647,8 @@ sexp sexp_make_flonum (sexp ctx, float f) {
sexp sexp_make_string_op (sexp ctx sexp_api_params(self, n), sexp len, sexp ch) {
sexp_sint_t clen = sexp_unbox_fixnum(len);
sexp s;
if (! sexp_fixnump(len)) return sexp_type_exception(ctx, self, SEXP_FIXNUM, len);
if (clen < 0) return sexp_user_exception(ctx, self, "negative length", len);
sexp_assert_type(ctx, sexp_fixnump, SEXP_FIXNUM, len);
if (clen < 0) return sexp_xtype_exception(ctx, self, "negative length", len);
s = sexp_alloc_atomic(ctx, sexp_sizeof(string)+clen+1);
if (sexp_exceptionp(s)) return s;
sexp_pointer_tag(s) = SEXP_STRING;
@ -673,14 +669,11 @@ sexp sexp_c_string (sexp ctx, const char *str, sexp_sint_t slen) {
sexp sexp_substring_op (sexp ctx sexp_api_params(self, n), sexp str, sexp start, sexp end) {
sexp res;
if (! sexp_stringp(str))
return sexp_type_exception(ctx, self, SEXP_STRING, str);
if (! sexp_fixnump(start))
return sexp_type_exception(ctx, self, SEXP_FIXNUM, start);
sexp_assert_type(ctx, sexp_stringp, SEXP_STRING, str);
sexp_assert_type(ctx, sexp_fixnump, SEXP_FIXNUM, start);
if (sexp_not(end))
end = sexp_make_fixnum(sexp_string_length(str));
if (! sexp_fixnump(end))
return sexp_type_exception(ctx, self, SEXP_FIXNUM, end);
sexp_assert_type(ctx, sexp_fixnump, SEXP_FIXNUM, end);
if ((sexp_unbox_fixnum(start) < 0)
|| (sexp_unbox_fixnum(start) > sexp_string_length(str))
|| (sexp_unbox_fixnum(end) < 0)
@ -787,8 +780,7 @@ sexp sexp_intern(sexp ctx, const char *str, sexp_sint_t len) {
}
sexp sexp_string_to_symbol_op (sexp ctx sexp_api_params(self, n), sexp str) {
if (! sexp_stringp(str))
return sexp_type_exception(ctx, self, SEXP_STRING, str);
sexp_assert_type(ctx, sexp_stringp, SEXP_STRING, str);
return sexp_intern(ctx, sexp_string_data(str), sexp_string_length(str));
}
@ -940,8 +932,7 @@ sexp sexp_get_output_string_op (sexp ctx sexp_api_params(self, n), sexp port) {
sexp sexp_make_input_string_port_op (sexp ctx sexp_api_params(self, n), sexp str) {
FILE *in;
sexp res;
if (! sexp_stringp(str))
return sexp_type_exception(ctx, self, SEXP_STRING, str);
sexp_assert_type(ctx, sexp_stringp, SEXP_STRING, str);
if (sexp_string_length(str) == 0)
in = fopen("/dev/null", "r");
else
@ -1011,9 +1002,8 @@ sexp sexp_buffered_write_string (sexp ctx, const char *str, sexp p) {
sexp sexp_buffered_flush (sexp ctx, sexp p) {
sexp_gc_var1(tmp);
if (! sexp_oportp(p))
return sexp_type_exception(ctx, NULL, SEXP_OPORT, p);
else if (! sexp_port_openp(p))
sexp_assert_type(ctx, sexp_oportp, SEXP_OPORT, p);
if (! sexp_port_openp(p))
return sexp_user_exception(ctx, SEXP_FALSE, "port is closed", p);
else {
if (sexp_port_stream(p)) {
@ -1032,8 +1022,7 @@ sexp sexp_buffered_flush (sexp ctx, sexp p) {
sexp sexp_make_input_string_port_op (sexp ctx sexp_api_params(self, n), sexp str) {
sexp res;
if (! sexp_stringp(str))
return sexp_type_exception(ctx, self, SEXP_STRING, str);
sexp_assert_type(ctx, sexp_stringp, SEXP_STRING, str);
res = sexp_make_input_port(ctx, NULL, SEXP_FALSE);
if (sexp_exceptionp(res)) return res;
sexp_port_cookie(res) = str;
@ -1272,17 +1261,14 @@ sexp sexp_write_one (sexp ctx, sexp obj, sexp out) {
}
sexp sexp_write_op (sexp ctx sexp_api_params(self, n), sexp obj, sexp out) {
if (! sexp_oportp(out))
return sexp_type_exception(ctx, self, SEXP_OPORT, out);
else
sexp_assert_type(ctx, sexp_oportp, SEXP_OPORT, out);
return sexp_write_one(ctx, obj, out);
}
sexp sexp_display_op (sexp ctx sexp_api_params(self, n), sexp obj, sexp out) {
sexp res=SEXP_VOID;
if (! sexp_oportp(out))
res = sexp_type_exception(ctx, self, SEXP_OPORT, out);
else if (sexp_stringp(obj))
sexp_assert_type(ctx, sexp_oportp, SEXP_OPORT, out);
if (sexp_stringp(obj))
sexp_write_string(ctx, sexp_string_data(obj), out);
else if (sexp_charp(obj))
sexp_write_char(ctx, sexp_unbox_character(obj), out);
@ -1694,10 +1680,8 @@ sexp sexp_read_raw (sexp ctx, sexp in) {
sexp sexp_read_op (sexp ctx sexp_api_params(self, n), sexp in) {
sexp res;
if (sexp_iportp(in))
sexp_assert_type(ctx, sexp_iportp, SEXP_IPORT, in);
res = sexp_read_raw(ctx, in);
else
res = sexp_type_exception(ctx, self, SEXP_IPORT, in);
if (res == SEXP_CLOSE)
res = sexp_read_error(ctx, "too many ')'s", SEXP_NULL, in);
if (res == SEXP_RAWDOT)
@ -1719,10 +1703,8 @@ sexp sexp_read_from_string (sexp ctx, const char *str, sexp_sint_t len) {
sexp sexp_string_to_number_op (sexp ctx sexp_api_params(self, n), sexp str, sexp b) {
int base;
sexp_gc_var1(in);
if (! sexp_stringp(str))
return sexp_type_exception(ctx, self, SEXP_STRING, str);
else if (! sexp_numberp(b))
return sexp_type_exception(ctx, self, SEXP_FIXNUM, b);
sexp_assert_type(ctx, sexp_stringp, SEXP_STRING, str);
sexp_assert_type(ctx, sexp_fixnump, SEXP_FIXNUM, b);
if (((base=sexp_unbox_fixnum(b)) < 2) || (base > 36))
return sexp_user_exception(ctx, self, "invalid numeric base", b);
sexp_gc_preserve1(ctx, in);