diff --git a/eval.c b/eval.c index 693ec8f5..af6fb097 100644 --- a/eval.c +++ b/eval.c @@ -93,12 +93,12 @@ sexp sexp_env_define (sexp ctx, sexp env, sexp key, sexp value) { sexp cell = sexp_assq(ctx, key, sexp_env_bindings(env)), res=SEXP_VOID; sexp_gc_var1(tmp); if (sexp_immutablep(env)) { - res = sexp_type_exception(ctx, "immutable binding", key); + res = sexp_user_exception(ctx, NULL, "immutable binding", key); } else { sexp_gc_preserve1(ctx, tmp); if (sexp_truep(cell)) { if (sexp_immutablep(cell)) - res = sexp_type_exception(ctx, "immutable binding", key); + res = sexp_user_exception(ctx, NULL, "immutable binding", key); else sexp_cdr(cell) = value; } else { @@ -2029,24 +2029,23 @@ static sexp sexp_exception_type_op (sexp ctx sexp_api_params(self, n), sexp exn) if (sexp_exceptionp(exn)) return sexp_exception_kind(exn); else - return sexp_type_exception(ctx, "not an exception", exn); + 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, "not a string", path); + return sexp_type_exception(ctx, self, SEXP_STRING, path); in = fopen(sexp_string_data(path), "r"); if (! in) - return - sexp_user_exception(ctx, SEXP_FALSE, "couldn't open input file", path); + return sexp_user_exception(ctx, self, "couldn't open input file", path); return sexp_make_input_port(ctx, in, path); } 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, "not a string", path); + return sexp_type_exception(ctx, self, SEXP_STRING, path); out = fopen(sexp_string_data(path), "w"); if (! out) return @@ -2056,7 +2055,7 @@ static sexp sexp_open_output_file_op (sexp ctx sexp_api_params(self, n), sexp pa static sexp sexp_close_port_op (sexp ctx sexp_api_params(self, n), sexp port) { if (! sexp_portp(port)) - return sexp_type_exception(ctx, "not a port", port); + return sexp_type_exception(ctx, self, SEXP_OPORT, port); if (! sexp_port_openp(port)) return sexp_user_exception(ctx, SEXP_FALSE, "port already closed", port); return sexp_finalize_port(ctx sexp_api_pass(self, n), port); @@ -2110,9 +2109,9 @@ sexp sexp_load_op (sexp ctx sexp_api_params(self, n), sexp source, sexp env) { sexp tmp, out=SEXP_FALSE; sexp_gc_var4(ctx2, x, in, res); if (! sexp_stringp(source)) - return sexp_type_exception(ctx, "not a string", source); + return sexp_type_exception(ctx, self, SEXP_STRING, source); if (! sexp_envp(env)) - return sexp_type_exception(ctx, "not an environment", env); + return sexp_type_exception(ctx, self, SEXP_ENV, env); #if SEXP_USE_DL suffix = sexp_string_data(source) + sexp_string_length(source) - strlen(sexp_so_extension); @@ -2165,7 +2164,7 @@ sexp sexp_load_op (sexp ctx sexp_api_params(self, n), sexp source, sexp env) { #endif #define define_math_op(name, cname) \ - static sexp name (sexp ctx, sexp z) { \ + static sexp name (sexp ctx sexp_api_params(self, n), sexp z) { \ double d; \ if (sexp_flonump(z)) \ d = sexp_flonum_value(z); \ @@ -2173,7 +2172,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, "not a number", z); \ + return sexp_type_exception(ctx, self, SEXP_FIXNUM, z); \ return sexp_make_flonum(ctx, cname(d)); \ } @@ -2190,7 +2189,7 @@ define_math_op(sexp_trunc, trunc) define_math_op(sexp_floor, floor) define_math_op(sexp_ceiling, ceil) -static sexp sexp_sqrt (sexp ctx, sexp z) { +static sexp sexp_sqrt (sexp ctx sexp_api_params(self, n), sexp z) { double d, r; if (sexp_flonump(z)) d = sexp_flonum_value(z); @@ -2198,7 +2197,7 @@ static sexp sexp_sqrt (sexp ctx, sexp z) { d = (double)sexp_unbox_fixnum(z); maybe_convert_bignum(z) /* XXXX add bignum sqrt */ else - return sexp_type_exception(ctx, "not a number", z); + return sexp_type_exception(ctx, self, SEXP_FIXNUM, z); r = sqrt(d); if (sexp_fixnump(z) && ((r*r) == (double)sexp_unbox_fixnum(z))) return sexp_make_fixnum(round(r)); @@ -2232,7 +2231,7 @@ static sexp sexp_expt_op (sexp ctx sexp_api_params(self, n), sexp x, sexp e) { x1 = sexp_flonum_value(x); #endif else - return sexp_type_exception(ctx, "expt: not a number", x); + return sexp_type_exception(ctx, self, SEXP_FIXNUM, x); if (sexp_fixnump(e)) e1 = sexp_unbox_fixnum(e); #if SEXP_USE_FLONUMS @@ -2240,7 +2239,7 @@ static sexp sexp_expt_op (sexp ctx sexp_api_params(self, n), sexp x, sexp e) { e1 = sexp_flonum_value(e); #endif else - return sexp_type_exception(ctx, "expt: not a number", e); + return sexp_type_exception(ctx, self, SEXP_FIXNUM, e); f = pow(x1, e1); if ((f > SEXP_MAX_FIXNUM) || (f < SEXP_MIN_FIXNUM) #if SEXP_USE_FLONUMS @@ -2268,9 +2267,9 @@ 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, "not a string", str1); + return sexp_type_exception(ctx, self, SEXP_STRING, str1); if (! sexp_stringp(str2)) - return sexp_type_exception(ctx, "not a string", str2); + return sexp_type_exception(ctx, self, SEXP_STRING, str2); len1 = sexp_string_length(str1); len2 = sexp_string_length(str2); len = ((len1= SEXP_OPC_NUM_OP_CLASSES)) - res = sexp_type_exception(ctx, "make-opcode: bad opcode class", op_class); + res = sexp_user_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_type_exception(ctx, "make-opcode: bad opcode", code); + res = sexp_user_exception(ctx, self, "make-opcode: bad opcode", code); else if (! sexp_fixnump(num_args)) - res = sexp_type_exception(ctx, "make-opcode: bad num_args", num_args); + res = sexp_type_exception(ctx, self, SEXP_FIXNUM, num_args); else if (! sexp_fixnump(flags)) - res = sexp_type_exception(ctx, "make-opcode: bad flags", flags); + res = sexp_type_exception(ctx, self, SEXP_FIXNUM, flags); else { res = sexp_alloc_type(ctx, opcode, SEXP_OPCODE); sexp_opcode_class(res) = sexp_unbox_fixnum(op_class); @@ -2359,7 +2358,7 @@ sexp sexp_make_foreign (sexp ctx, const char *name, int num_args, int flags, sexp_proc1 f, sexp data) { sexp res; if (num_args > 6) { - res = sexp_type_exception(ctx, "make-foreign: exceeded foreign arg limit", + res = sexp_user_exception(ctx, NULL, "make-foreign: exceeded foreign arg limit", sexp_make_fixnum(num_args)); } else { res = sexp_alloc_type(ctx, opcode, SEXP_OPCODE); @@ -2405,8 +2404,8 @@ sexp sexp_define_foreign_param (sexp ctx, sexp env, const char *name, int num_ar 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, "make-type-predicate: bad type", type); - return sexp_make_opcode(ctx, name, sexp_make_fixnum(SEXP_OPC_TYPE_PREDICATE), + return sexp_type_exception(ctx, self, 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); } @@ -2414,9 +2413,9 @@ 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, "make-constructor: bad type", type); + return sexp_type_exception(ctx, self, SEXP_FIXNUM, type); type_size = sexp_type_size_base(sexp_type_by_index(ctx, sexp_unbox_fixnum(type))); - return sexp_make_opcode(ctx, name, sexp_make_fixnum(SEXP_OPC_CONSTRUCTOR), + return sexp_make_opcode(ctx, self, name, sexp_make_fixnum(SEXP_OPC_CONSTRUCTOR), sexp_make_fixnum(SEXP_OP_MAKE), SEXP_ZERO, SEXP_ZERO, SEXP_ZERO, SEXP_ZERO, SEXP_ZERO, type, sexp_make_fixnum(type_size), NULL); @@ -2424,22 +2423,22 @@ sexp sexp_make_constructor_op (sexp ctx sexp_api_params(self, n), sexp name, sex sexp sexp_make_getter_op (sexp ctx sexp_api_params(self, n), sexp name, sexp type, sexp index) { if ((! sexp_fixnump(type)) || (sexp_unbox_fixnum(type) < 0)) - return sexp_type_exception(ctx, "make-getter: bad type", type); + return sexp_type_exception(ctx, self, SEXP_FIXNUM, type); if ((! sexp_fixnump(index)) || (sexp_unbox_fixnum(index) < 0)) - return sexp_type_exception(ctx, "make-getter: bad index", index); + return sexp_type_exception(ctx, self, SEXP_FIXNUM, index); return - sexp_make_opcode(ctx, name, sexp_make_fixnum(SEXP_OPC_GETTER), + sexp_make_opcode(ctx, self, name, sexp_make_fixnum(SEXP_OPC_GETTER), sexp_make_fixnum(SEXP_OP_SLOT_REF), SEXP_ONE, SEXP_ZERO, type, SEXP_ZERO, SEXP_ZERO, type, index, NULL); } sexp sexp_make_setter_op (sexp ctx sexp_api_params(self, n), sexp name, sexp type, sexp index) { if ((! sexp_fixnump(type)) || (sexp_unbox_fixnum(type) < 0)) - return sexp_type_exception(ctx, "make-setter: bad type", type); + return sexp_type_exception(ctx, self, SEXP_FIXNUM, type); if ((! sexp_fixnump(index)) || (sexp_unbox_fixnum(index) < 0)) - return sexp_type_exception(ctx, "make-setter: bad index", index); + return sexp_type_exception(ctx, self, SEXP_FIXNUM, index); return - sexp_make_opcode(ctx, name, sexp_make_fixnum(SEXP_OPC_SETTER), + sexp_make_opcode(ctx, self, name, sexp_make_fixnum(SEXP_OPC_SETTER), sexp_make_fixnum(SEXP_OP_SLOT_SET), SEXP_TWO, SEXP_ZERO, type, SEXP_ZERO, SEXP_ZERO, type, index, NULL); } @@ -2553,15 +2552,15 @@ 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, "not a string", file); + return sexp_type_exception(ctx, self, SEXP_STRING, file); else 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, "not a string", file); + return sexp_type_exception(ctx, self, SEXP_STRING, file); else if (! sexp_envp(env)) - return sexp_type_exception(ctx, "not an environment", env); + return sexp_type_exception(ctx, self, SEXP_ENV, env); return sexp_load_module_file(ctx, sexp_string_data(file), env); } #endif @@ -2569,7 +2568,7 @@ sexp sexp_load_module_file_op (sexp ctx sexp_api_params(self, n), sexp file, sex 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, "not a string", dir); + return sexp_type_exception(ctx, self, 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)) @@ -2709,7 +2708,7 @@ sexp sexp_apply (sexp ctx, sexp proc, sexp args) { proc = make_opcode_procedure(ctx, proc, len); if (! sexp_procedurep(proc)) { res = sexp_exceptionp(proc) ? proc : - sexp_type_exception(ctx, "apply: not a procedure", proc); + sexp_type_exception(ctx, NULL, SEXP_PROCEDURE, proc); } else { offset = top + len; for (ls=args; sexp_pairp(ls); ls=sexp_cdr(ls), top++) @@ -2753,7 +2752,7 @@ sexp sexp_eval_op (sexp ctx sexp_api_params(self, n), sexp obj, sexp env) { if (! env) env = sexp_context_env(ctx); else if (! sexp_envp(env)) - return sexp_type_exception(ctx, "eval: not an env", env); + return sexp_type_exception(ctx, self, 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)); diff --git a/gc.c b/gc.c index 399dd6b8..d0a2dc94 100644 --- a/gc.c +++ b/gc.c @@ -234,14 +234,14 @@ sexp sexp_copy_context (sexp ctx, sexp dst, sexp flags) { /* validate input, creating a new heap if needed */ if (from->next) { - return sexp_type_exception(ctx, "can't copy a non-contiguous heap", ctx); + return sexp_user_exception(ctx, NULL, "can't copy a non-contiguous heap", ctx); } else if (! dst || sexp_not(dst)) { to = sexp_make_heap(from->size); dst = (sexp) ((char*)ctx + ((char*)to - (char*)from)); } else if (! sexp_contextp(dst)) { - return sexp_type_exception(ctx, "destination not a context", dst); + return sexp_type_exception(ctx, NULL, SEXP_CONTEXT, dst); } else if (sexp_context_heap(dst)->size < from->size) { - return sexp_type_exception(ctx, "destination context too small", dst); + return sexp_user_exception(ctx, NULL, "destination context too small", dst); } else { to = sexp_context_heap(dst); } diff --git a/include/chibi/eval.h b/include/chibi/eval.h index 07dd9ac8..1994bc74 100644 --- a/include/chibi/eval.h +++ b/include/chibi/eval.h @@ -151,7 +151,7 @@ SEXP_API sexp sexp_env_cell (sexp env, sexp sym); SEXP_API sexp sexp_env_ref (sexp env, sexp sym, sexp dflt); SEXP_API sexp sexp_env_global_ref (sexp env, sexp sym, sexp dflt); SEXP_API void sexp_warn_undefs (sexp ctx, sexp from, sexp to, sexp out); -SEXP_API sexp sexp_make_opcode (sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp_proc1); +SEXP_API sexp sexp_make_opcode (sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp_proc1); SEXP_API sexp sexp_make_procedure (sexp ctx, sexp flags, sexp num_args, sexp bc, sexp vars); SEXP_API sexp sexp_make_foreign (sexp ctx, const char *name, int num_args, int flags, sexp_proc1 f, sexp data); SEXP_API sexp sexp_define_foreign_aux (sexp ctx, sexp env, const char *name, int num_args, int flags, sexp_proc1 f, sexp data); diff --git a/include/chibi/sexp.h b/include/chibi/sexp.h index ace6463e..b110a973 100644 --- a/include/chibi/sexp.h +++ b/include/chibi/sexp.h @@ -74,6 +74,7 @@ enum sexp_types { SEXP_OBJECT, SEXP_TYPE, SEXP_FIXNUM, + SEXP_NUMBER, SEXP_CHAR, SEXP_BOOLEAN, SEXP_PAIR, @@ -868,11 +869,14 @@ SEXP_API sexp sexp_make_output_string_port_op (sexp ctx sexp_api_params(self, n) SEXP_API sexp sexp_get_output_string_op (sexp ctx sexp_api_params(self, n), sexp port); SEXP_API sexp sexp_make_exception (sexp ctx, sexp kind, sexp message, sexp irritants, sexp procedure, sexp source); SEXP_API sexp sexp_user_exception (sexp ctx, sexp self, const char *msg, sexp x); -SEXP_API sexp sexp_type_exception (sexp ctx, const char *message, sexp x); +SEXP_API sexp sexp_type_exception (sexp ctx, sexp self, sexp_uint_t type_id, sexp x); +SEXP_API sexp sexp_xtype_exception (sexp ctx, sexp self, const char *msg, sexp x); SEXP_API sexp sexp_range_exception (sexp ctx, sexp obj, sexp start, sexp end); SEXP_API sexp sexp_print_exception_op (sexp ctx sexp_api_params(self, n), sexp exn, sexp out); SEXP_API void sexp_init(void); +#define sexp_assert_type(ctx, pred, type_id, obj) if (! pred(obj)) return sexp_type_exception(ctx, self, type_id, obj) + #define SEXP_COPY_DEFAULT SEXP_ZERO #define SEXP_COPY_FREEP SEXP_ONE diff --git a/lib/chibi/ast.c b/lib/chibi/ast.c index 9171cb02..2b740f41 100644 --- a/lib/chibi/ast.c +++ b/lib/chibi/ast.c @@ -1,11 +1,10 @@ -/* ast.c -- interface to the Abstract Syntax Tree */ -/* Copyright (c) 2009 Alex Shinn. All rights reserved. */ -/* BSD-style license: http://synthcode.com/license.txt */ +/* ast.c -- interface to the Abstract Syntax Tree */ +/* Copyright (c) 2009-2010 Alex Shinn. All rights reserved. */ +/* BSD-style license: http://synthcode.com/license.txt */ #include -static void sexp_define_type_predicate (sexp ctx, sexp env, - char *cname, sexp_uint_t type) { +static void sexp_define_type_predicate (sexp ctx, sexp env, char *cname, sexp_uint_t type) { sexp_gc_var2(name, op); sexp_gc_preserve2(ctx, name, op); name = sexp_c_string(ctx, cname, -1); @@ -28,7 +27,7 @@ static void sexp_define_accessors (sexp ctx, sexp env, sexp_uint_t ctype, sexp_gc_release2(ctx); } -static sexp sexp_get_env_cell (sexp ctx, sexp env, sexp id) { +static sexp sexp_get_env_cell (sexp ctx sexp_api_params(self, n), sexp env, sexp id) { sexp cell = sexp_env_cell(env, id); while ((! cell) && sexp_synclop(id)) { env = sexp_synclo_env(id); @@ -37,9 +36,9 @@ static sexp sexp_get_env_cell (sexp ctx, sexp env, sexp id) { return cell ? cell : SEXP_FALSE; } -static sexp sexp_get_opcode_name (sexp ctx, sexp op) { +static sexp sexp_get_opcode_name (sexp ctx sexp_api_params(self, n), sexp op) { if (! sexp_opcodep(op)) - return sexp_type_exception(ctx, "not an opcode", op); + return sexp_type_exception(ctx, self, SEXP_OPCODE, op); else if (! sexp_opcode_name(op)) return SEXP_FALSE; else diff --git a/lib/chibi/disasm.c b/lib/chibi/disasm.c index 78977222..57dcf94d 100644 --- a/lib/chibi/disasm.c +++ b/lib/chibi/disasm.c @@ -1,6 +1,6 @@ -/* disasm.c -- optional debugging utilities */ -/* Copyright (c) 2009 Alex Shinn. All rights reserved. */ -/* BSD-style license: http://synthcode.com/license.txt */ +/* disasm.c -- optional debugging utilities */ +/* Copyright (c) 2009-2010 Alex Shinn. All rights reserved. */ +/* BSD-style license: http://synthcode.com/license.txt */ #include "chibi/eval.h" @@ -23,7 +23,7 @@ static const char* reverse_opcode_names[] = "WRITE-CHAR", "NEWLINE", "READ-CHAR", "PEEK-CHAR", "RET", "DONE", }; -static sexp disasm (sexp ctx, sexp bc, sexp out, int depth) { +static sexp disasm (sexp ctx, sexp self, sexp bc, sexp out, int depth) { sexp tmp; unsigned char *ip, opcode, i; @@ -33,10 +33,10 @@ static sexp disasm (sexp ctx, sexp bc, sexp out, int depth) { sexp_printf(ctx, out, "%s is a primitive\n", sexp_opcode_name(bc)); return SEXP_VOID; } else if (! sexp_bytecodep(bc)) { - return sexp_type_exception(ctx, "not a procedure", bc); + return sexp_type_exception(ctx, self, SEXP_BYTECODE, bc); } if (! sexp_oportp(out)) { - return sexp_type_exception(ctx, "not an output-port", out); + return sexp_type_exception(ctx, self, SEXP_OPORT, out); } for (i=0; i<(depth*SEXP_DISASM_PAD_WIDTH); i++) @@ -100,14 +100,14 @@ static sexp disasm (sexp ctx, sexp bc, sexp out, int depth) { sexp_write_char(ctx, '\n', out); if ((opcode == SEXP_OP_PUSH) && (depth < SEXP_DISASM_MAX_DEPTH) && (sexp_bytecodep(tmp) || sexp_procedurep(tmp))) - disasm(ctx, tmp, out, depth+1); + disasm(ctx, self, tmp, out, depth+1); if (ip - sexp_bytecode_data(bc) < sexp_bytecode_length(bc)) goto loop; return SEXP_VOID; } -static sexp sexp_disasm (sexp ctx, sexp bc, sexp out) { - return disasm(ctx, bc, out, 0); +static sexp sexp_disasm (sexp ctx sexp_api_params(self, n), sexp bc, sexp out) { + return disasm(ctx, self, bc, out, 0); } sexp sexp_init_library (sexp ctx sexp_api_params(self, n), sexp env) { diff --git a/lib/chibi/heap-stats.c b/lib/chibi/heap-stats.c index 0e455ba9..976b5b27 100644 --- a/lib/chibi/heap-stats.c +++ b/lib/chibi/heap-stats.c @@ -1,6 +1,6 @@ -/* heap-stats.c -- count or dump heap objects */ -/* Copyright (c) 2009 Alex Shinn. All rights reserved. */ -/* BSD-style license: http://synthcode.com/license.txt */ +/* heap-stats.c -- count or dump heap objects */ +/* Copyright (c) 2009-2010 Alex Shinn. All rights reserved. */ +/* BSD-style license: http://synthcode.com/license.txt */ #include @@ -111,13 +111,13 @@ static sexp sexp_heap_walk (sexp ctx, int depth, int printp) { return res; } -static sexp sexp_heap_stats (sexp ctx) { +static sexp sexp_heap_stats (sexp ctx sexp_api_params(self, n)) { return sexp_heap_walk(ctx, 0, 0); } -static sexp sexp_heap_dump (sexp ctx, sexp depth) { +static sexp sexp_heap_dump (sexp ctx sexp_api_params(self, n), sexp depth) { if (! sexp_fixnump(depth) || (sexp_unbox_fixnum(depth) < 0)) - return sexp_type_exception(ctx, "bad heap-dump depth", depth); + return sexp_xtype_exception(ctx, self, "bad heap-dump depth", depth); return sexp_heap_walk(ctx, sexp_unbox_fixnum(depth), 1); } diff --git a/lib/chibi/io/io.stub b/lib/chibi/io/io.stub index 208d0a18..07450dc0 100644 --- a/lib/chibi/io/io.stub +++ b/lib/chibi/io/io.stub @@ -21,7 +21,7 @@ (c-include "port.c") (define-c sexp (%make-custom-input-port "sexp_make_custom_input_port") - ((value ctx sexp) sexp sexp sexp)) + ((value ctx sexp) (value self sexp) sexp sexp sexp)) (define-c sexp (%make-custom-output-port "sexp_make_custom_output_port") - ((value ctx sexp) sexp sexp sexp)) + ((value ctx sexp) (value self sexp) sexp sexp sexp)) diff --git a/lib/chibi/io/port.c b/lib/chibi/io/port.c index 770c94dd..947f3400 100644 --- a/lib/chibi/io/port.c +++ b/lib/chibi/io/port.c @@ -131,19 +131,20 @@ static cookie_io_functions_t sexp_cookie_no_seek = { #if SEXP_USE_STRING_STREAMS -static sexp sexp_make_custom_port (sexp ctx, char *mode, sexp read, sexp write, +static sexp sexp_make_custom_port (sexp ctx, sexp self, char *mode, + sexp read, sexp write, sexp seek, sexp close) { FILE *in; sexp res; sexp_gc_var1(vec); if (sexp_truep(read) && ! sexp_procedurep(read)) - return sexp_type_exception(ctx, "make-custom-port: read not a procedure", read); + return sexp_type_exception(ctx, self, SEXP_PROCEDURE, read); if (sexp_truep(write) && ! sexp_procedurep(write)) - return sexp_type_exception(ctx, "make-custom-port: write not a procedure", write); + return sexp_type_exception(ctx, self, SEXP_PROCEDURE, write); if (sexp_truep(seek) && ! sexp_procedurep(seek)) - return sexp_type_exception(ctx, "make-custom-port: seek not a procedure", seek); + return sexp_type_exception(ctx, self, SEXP_PROCEDURE, seek); if (sexp_truep(close) && ! sexp_procedurep(close)) - return sexp_type_exception(ctx, "make-custom-port: close not a procedure", close); + return sexp_type_exception(ctx, self, SEXP_PROCEDURE, close); sexp_gc_preserve1(ctx, vec); vec = sexp_make_vector(ctx, SEXP_SIX, SEXP_VOID); sexp_cookie_ctx(vec) = ctx; @@ -163,7 +164,7 @@ static sexp sexp_make_custom_port (sexp ctx, char *mode, sexp read, sexp write, in = fopencookie(vec, mode, (sexp_truep(seek) ? sexp_cookie : sexp_cookie_no_seek)); #endif if (! in) { - res = sexp_user_exception(ctx, read, "couldn't make custom port", read); + res = sexp_user_exception(ctx, self, "couldn't make custom port", read); } else { res = sexp_make_input_port(ctx, in, SEXP_FALSE); sexp_port_cookie(res) = vec; /* for gc preserving */ @@ -174,19 +175,22 @@ static sexp sexp_make_custom_port (sexp ctx, char *mode, sexp read, sexp write, #else -static sexp sexp_make_custom_port (sexp ctx, char *mode, sexp read, sexp write, +static sexp sexp_make_custom_port (sexp ctx, sexp self, + char *mode, sexp read, sexp write, sexp seek, sexp close) { - return sexp_user_exception(ctx, SEXP_FALSE, "custom ports not supported in this configuration", SEXP_NULL); + return sexp_user_exception(ctx, self, "custom ports not supported in this configuration", SEXP_NULL); } #endif -static sexp sexp_make_custom_input_port (sexp ctx, sexp read, sexp seek, sexp close) { - return sexp_make_custom_port(ctx, "r", read, SEXP_FALSE, seek, close); +static sexp sexp_make_custom_input_port (sexp ctx, sexp self, + sexp read, sexp seek, sexp close) { + return sexp_make_custom_port(ctx, self, "r", read, SEXP_FALSE, seek, close); } -static sexp sexp_make_custom_output_port (sexp ctx, sexp write, sexp seek, sexp close) { - sexp res = sexp_make_custom_port(ctx, "w", SEXP_FALSE, write, seek, close); +static sexp sexp_make_custom_output_port (sexp ctx, sexp self, + sexp write, sexp seek, sexp close) { + sexp res = sexp_make_custom_port(ctx, self, "w", SEXP_FALSE, write, seek, close); sexp_pointer_tag(res) = SEXP_OPORT; return res; } diff --git a/lib/chibi/process.stub b/lib/chibi/process.stub index 7dbca7eb..17287d30 100644 --- a/lib/chibi/process.stub +++ b/lib/chibi/process.stub @@ -42,7 +42,7 @@ (c-include "signal.c") (define-c sexp (set-signal-action! "sexp_set_signal_action") - ((value ctx sexp) sexp sexp)) + ((value ctx sexp) (value self sexp) sexp sexp)) (define-c errno (make-signal-set "sigemptyset") ((result sigset_t))) (define-c errno (signal-set-fill! "sigfillset") (sigset_t)) diff --git a/lib/chibi/signal.c b/lib/chibi/signal.c index 463e481d..ea23929f 100644 --- a/lib/chibi/signal.c +++ b/lib/chibi/signal.c @@ -35,15 +35,15 @@ static struct sigaction call_sigaction = { static struct sigaction call_sigdefault = {.sa_handler = SIG_DFL}; static struct sigaction call_sigignore = {.sa_handler = SIG_IGN}; -static sexp sexp_set_signal_action (sexp ctx, sexp signum, sexp newaction) { +static sexp sexp_set_signal_action (sexp ctx, sexp self, sexp signum, sexp newaction) { int res; sexp oldaction; if (! (sexp_fixnump(signum) && sexp_unbox_fixnum(signum) > 0 && sexp_unbox_fixnum(signum) < SEXP_MAX_SIGNUM)) - return sexp_type_exception(ctx, "not a valid signal number", signum); + return sexp_xtype_exception(ctx, self, "not a valid signal number", signum); if (! (sexp_procedurep(newaction) || sexp_opcodep(newaction) || sexp_booleanp(newaction))) - return sexp_type_exception(ctx, "not a procedure", newaction); + return sexp_type_exception(ctx, self, SEXP_PROCEDURE, newaction); if (! sexp_vectorp(sexp_global(ctx, SEXP_G_SIGNAL_HANDLERS))) sexp_global(ctx, SEXP_G_SIGNAL_HANDLERS) = sexp_make_vector(ctx, sexp_make_fixnum(SEXP_MAX_SIGNUM), SEXP_FALSE); @@ -54,7 +54,7 @@ static sexp sexp_set_signal_action (sexp ctx, sexp signum, sexp newaction) { : &call_sigaction), NULL); if (res) - return sexp_user_exception(ctx, SEXP_FALSE, "couldn't set signal", signum); + return sexp_user_exception(ctx, self, "couldn't set signal", signum); sexp_vector_set(sexp_global(ctx, SEXP_G_SIGNAL_HANDLERS), signum, newaction); sexp_signal_contexts[sexp_unbox_fixnum(signum)] = ctx; return oldaction; diff --git a/lib/srfi/27/rand.c b/lib/srfi/27/rand.c index 210b9e42..d70f8726 100644 --- a/lib/srfi/27/rand.c +++ b/lib/srfi/27/rand.c @@ -44,7 +44,7 @@ static sexp sexp_rs_random_integer (sexp ctx sexp_api_params(self, n), sexp rs, int32_t hi, mod, len, i, *data; #endif if (! sexp_random_source_p(rs)) - res = sexp_type_exception(ctx, "not a random-source", rs); + res = sexp_type_exception(ctx, self, rs_type_id, rs); if (sexp_fixnump(bound)) { sexp_call_random(rs, m); res = sexp_make_fixnum(m % sexp_unbox_fixnum(bound)); @@ -64,7 +64,7 @@ static sexp sexp_rs_random_integer (sexp ctx sexp_api_params(self, n), sexp rs, data[i] = m % mod; #endif } else { - res = sexp_type_exception(ctx, "random-integer: not an integer", bound); + res = sexp_type_exception(ctx, self, SEXP_FIXNUM, bound); } return res; } @@ -76,7 +76,7 @@ static sexp sexp_random_integer (sexp ctx sexp_api_params(self, n), sexp bound) static sexp sexp_rs_random_real (sexp ctx sexp_api_params(self, n), sexp rs) { int32_t res; if (! sexp_random_source_p(rs)) - return sexp_type_exception(ctx, "not a random-source", rs); + return sexp_type_exception(ctx, self, rs_type_id, rs); sexp_call_random(rs, res); return sexp_make_flonum(ctx, (double)res / (double)RAND_MAX); } @@ -96,14 +96,14 @@ static sexp sexp_make_random_source (sexp ctx sexp_api_params(self, n)) { static sexp sexp_random_source_state_ref (sexp ctx sexp_api_params(self, n), sexp rs) { if (! sexp_random_source_p(rs)) - return sexp_type_exception(ctx, "not a random-source", rs); + return sexp_type_exception(ctx, self, rs_type_id, rs); else return sexp_make_integer(ctx, *sexp_random_data(rs)); } static sexp sexp_random_source_state_set (sexp ctx sexp_api_params(self, n), sexp rs, sexp state) { if (! sexp_random_source_p(rs)) - return sexp_type_exception(ctx, "not a random-source", rs); + return sexp_type_exception(ctx, self, rs_type_id, rs); else if (sexp_fixnump(state)) *sexp_random_data(rs) = sexp_unbox_fixnum(state); #if SEXP_USE_BIGNUMS @@ -112,7 +112,7 @@ static sexp sexp_random_source_state_set (sexp ctx sexp_api_params(self, n), sex = sexp_bignum_data(state)[0]*sexp_bignum_sign(state); #endif else - return sexp_type_exception(ctx, "not a valid random-state", state); + return sexp_type_exception(ctx, self, SEXP_FIXNUM, state); return SEXP_VOID; } @@ -132,17 +132,17 @@ static sexp sexp_make_random_source (sexp ctx sexp_api_params(self, n)) { static sexp sexp_random_source_state_ref (sexp ctx sexp_api_params(self, n), sexp rs) { if (! sexp_random_source_p(rs)) - return sexp_type_exception(ctx, "not a random-source", rs); + return sexp_type_exception(ctx, self, rs_type_id, rs); else return sexp_substring(ctx, sexp_random_state(rs), ZERO, STATE_SIZE); } static sexp sexp_random_source_state_set (sexp ctx sexp_api_params(self, n), sexp rs, sexp state) { if (! sexp_random_source_p(rs)) - return sexp_type_exception(ctx, "not a random-source", rs); + return sexp_type_exception(ctx, self, rs_type_id, rs); else if (! (sexp_stringp(state) && (sexp_string_length(state) == SEXP_RANDOM_STATE_SIZE))) - return sexp_type_exception(ctx, "not a valid random-state", state); + return sexp_type_exception(ctx, self, SEXP_STRING, state); sexp_random_state(rs) = state; sexp_random_init(rs, 1); return SEXP_VOID; @@ -152,16 +152,16 @@ static sexp sexp_random_source_state_set (sexp ctx sexp_api_params(self, n), sex static sexp sexp_random_source_randomize (sexp ctx sexp_api_params(self, n), sexp rs) { if (! sexp_random_source_p(rs)) - return sexp_type_exception(ctx, "not a random-source", rs); + return sexp_type_exception(ctx, self, rs_type_id, rs); sexp_seed_random(time(NULL), rs); return SEXP_VOID; } static sexp sexp_random_source_pseudo_randomize (sexp ctx sexp_api_params(self, n), sexp rs, sexp seed) { if (! sexp_random_source_p(rs)) - return sexp_type_exception(ctx, "not a random-source", rs); + return sexp_type_exception(ctx, self, rs_type_id, rs); if (! sexp_fixnump(seed)) - return sexp_type_exception(ctx, "not an integer", seed); + return sexp_type_exception(ctx, self, rs_type_id, seed); sexp_seed_random(sexp_unbox_fixnum(seed), rs); return SEXP_VOID; } diff --git a/lib/srfi/33/bit.c b/lib/srfi/33/bit.c index b2e685a5..c7a8f843 100644 --- a/lib/srfi/33/bit.c +++ b/lib/srfi/33/bit.c @@ -1,6 +1,6 @@ -/* bit.c -- bitwise operators */ -/* Copyright (c) 2009 Alex Shinn. All rights reserved. */ -/* BSD-style license: http://synthcode.com/license.txt */ +/* bit.c -- bitwise operators */ +/* Copyright (c) 2009-2010 Alex Shinn. All rights reserved. */ +/* BSD-style license: http://synthcode.com/license.txt */ #include #include @@ -24,7 +24,7 @@ static sexp sexp_bit_and (sexp ctx sexp_api_params(self, n), sexp x, sexp y) { res = sexp_bit_and(ctx sexp_api_pass(self, n), y, x); #endif else - res = sexp_type_exception(ctx, "bitwise-and: not an integer", y); + res = sexp_type_exception(ctx, self, SEXP_FIXNUM, y); #if SEXP_USE_BIGNUMS } else if (sexp_bignump(x)) { if (sexp_fixnump(y)) { @@ -38,11 +38,11 @@ static sexp sexp_bit_and (sexp ctx sexp_api_params(self, n), sexp x, sexp y) { sexp_bignum_data(res)[i] = sexp_bignum_data(x)[i] & sexp_bignum_data(y)[i]; } else { - res = sexp_type_exception(ctx, "bitwise-and: not an integer", y); + res = sexp_type_exception(ctx, self, SEXP_FIXNUM, y); } #endif } else { - res = sexp_type_exception(ctx, "bitwise-and: not an integer", x); + res = sexp_type_exception(ctx, self, SEXP_FIXNUM, x); } return sexp_bignum_normalize(res); } @@ -60,7 +60,7 @@ static sexp sexp_bit_ior (sexp ctx sexp_api_params(self, n), sexp x, sexp y) { res = sexp_bit_ior(ctx sexp_api_pass(self, n), y, x); #endif else - res = sexp_type_exception(ctx, "bitwise-ior: not an integer", y); + res = sexp_type_exception(ctx, self, SEXP_FIXNUM, y); #if SEXP_USE_BIGNUMS } else if (sexp_bignump(x)) { if (sexp_fixnump(y)) { @@ -78,11 +78,11 @@ static sexp sexp_bit_ior (sexp ctx sexp_api_params(self, n), sexp x, sexp y) { sexp_bignum_data(res)[i] = sexp_bignum_data(x)[i] | sexp_bignum_data(y)[i]; } else { - res = sexp_type_exception(ctx, "bitwise-ior: not an integer", y); + res = sexp_type_exception(ctx, self, SEXP_FIXNUM, y); } #endif } else { - res = sexp_type_exception(ctx, "bitwise-ior: not an integer", x); + res = sexp_type_exception(ctx, self, SEXP_FIXNUM, x); } return sexp_bignum_normalize(res); } @@ -100,7 +100,7 @@ static sexp sexp_bit_xor (sexp ctx sexp_api_params(self, n), sexp x, sexp y) { res = sexp_bit_xor(ctx sexp_api_pass(self, n), y, x); #endif else - res = sexp_type_exception(ctx, "bitwise-xor: not an integer", y); + res = sexp_type_exception(ctx, self, SEXP_FIXNUM, y); #if SEXP_USE_BIGNUMS } else if (sexp_bignump(x)) { if (sexp_fixnump(y)) { @@ -118,11 +118,11 @@ static sexp sexp_bit_xor (sexp ctx sexp_api_params(self, n), sexp x, sexp y) { sexp_bignum_data(res)[i] = sexp_bignum_data(x)[i] ^ sexp_bignum_data(y)[i]; } else { - res = sexp_type_exception(ctx, "bitwise-xor: not an integer", y); + res = sexp_type_exception(ctx, self, SEXP_FIXNUM, y); } #endif } else { - res = sexp_type_exception(ctx, "bitwise-xor: not an integer", x); + res = sexp_type_exception(ctx, self, SEXP_FIXNUM, x); } return sexp_bignum_normalize(res); } @@ -139,7 +139,7 @@ static sexp sexp_arithmetic_shift (sexp ctx sexp_api_params(self, n), sexp i, se sexp res; #endif if (! sexp_fixnump(count)) - return sexp_type_exception(ctx, "arithmetic-shift: not an integer", count); + return sexp_type_exception(ctx, self, SEXP_FIXNUM, count); c = sexp_unbox_fixnum(count); if (c == 0) return i; if (sexp_fixnump(i)) { @@ -192,7 +192,7 @@ static sexp sexp_arithmetic_shift (sexp ctx sexp_api_params(self, n), sexp i, se } #endif } else { - res = sexp_type_exception(ctx, "arithmetic-shift: not an integer", i); + res = sexp_type_exception(ctx, self, SEXP_FIXNUM, i); } return sexp_bignum_normalize(res); } @@ -224,7 +224,7 @@ static sexp sexp_bit_count (sexp ctx sexp_api_params(self, n), sexp x) { res = sexp_make_fixnum(count); #endif } else { - res = sexp_type_exception(ctx, "bit-count: not an integer", x); + res = sexp_type_exception(ctx, self, SEXP_FIXNUM, x); } return res; } @@ -265,7 +265,7 @@ static sexp sexp_integer_length (sexp ctx sexp_api_params(self, n), sexp x) { + hi*sizeof(sexp_uint_t)); #endif } else { - return sexp_type_exception(ctx, "integer-length: not an integer", x); + return sexp_type_exception(ctx, self, SEXP_FIXNUM, x); } } @@ -274,7 +274,7 @@ static sexp sexp_bit_set_p (sexp ctx sexp_api_params(self, n), sexp i, sexp x) { sexp_uint_t pos; #endif if (! sexp_fixnump(i)) - return sexp_type_exception(ctx, "bit-set?: not an integer", i); + return sexp_type_exception(ctx, self, SEXP_FIXNUM, i); if (sexp_fixnump(x)) { return sexp_make_boolean(sexp_unbox_fixnum(x) & (1< @@ -25,9 +25,9 @@ static sexp_uint_t string_hash (char *str, sexp_uint_t bound) { static sexp sexp_string_hash (sexp ctx sexp_api_params(self, n), sexp str, sexp bound) { if (! sexp_stringp(str)) - return sexp_type_exception(ctx, "string-hash: not a string", str); - else if (! sexp_integerp(bound)) - return sexp_type_exception(ctx, "string-hash: not an integer", bound); + return sexp_type_exception(ctx, self, SEXP_STRING, str); + else if (! sexp_fixnump(bound)) + return sexp_type_exception(ctx, self, SEXP_FIXNUM, bound); return sexp_make_fixnum(string_hash(sexp_string_data(str), sexp_unbox_fixnum(bound))); } @@ -40,9 +40,9 @@ static sexp_uint_t string_ci_hash (char *str, sexp_uint_t bound) { static sexp sexp_string_ci_hash (sexp ctx sexp_api_params(self, n), sexp str, sexp bound) { if (! sexp_stringp(str)) - return sexp_type_exception(ctx, "string-ci-hash: not a string", str); - else if (! sexp_integerp(bound)) - return sexp_type_exception(ctx, "string-ci-hash: not an integer", bound); + return sexp_type_exception(ctx, self, SEXP_STRING, str); + else if (! sexp_fixnump(bound)) + return sexp_type_exception(ctx, self, SEXP_FIXNUM, bound); return sexp_make_fixnum(string_ci_hash(sexp_string_data(str), sexp_unbox_fixnum(bound))); } @@ -91,13 +91,13 @@ static sexp_uint_t hash_one (sexp ctx, sexp obj, sexp_uint_t bound, sexp_sint_t static sexp sexp_hash (sexp ctx sexp_api_params(self, n), sexp obj, sexp bound) { if (! sexp_exact_integerp(bound)) - return sexp_type_exception(ctx, "hash: not an integer", bound); + return sexp_type_exception(ctx, self, SEXP_FIXNUM, bound); return sexp_make_fixnum(hash_one(ctx, obj, sexp_unbox_fixnum(bound), HASH_DEPTH)); } static sexp sexp_hash_by_identity (sexp ctx sexp_api_params(self, n), sexp obj, sexp bound) { if (! sexp_exact_integerp(bound)) - return sexp_type_exception(ctx, "hash-by-identity: not an integer", bound); + return sexp_type_exception(ctx, self, SEXP_FIXNUM, bound); return sexp_make_fixnum((sexp_uint_t)obj % sexp_unbox_fixnum(bound)); } @@ -184,8 +184,8 @@ static sexp sexp_hash_table_cell (sexp ctx sexp_api_params(self, n), sexp ht, se sexp buckets, eq_fn, hash_fn, i; sexp_uint_t size; sexp_gc_var1(res); - if (! sexp_pointerp(ht)) - return sexp_type_exception(ctx, "not a hash-table", ht); + if (! sexp_pointerp(ht)) /* XXXX check the real type id */ + return sexp_xtype_exception(ctx, self, "not a hash-table", ht); buckets = sexp_hash_table_buckets(ht); eq_fn = sexp_hash_table_eq_fn(ht); hash_fn = sexp_hash_table_hash_fn(ht); diff --git a/lib/srfi/95/qsort.c b/lib/srfi/95/qsort.c index 970f36b4..438820f9 100644 --- a/lib/srfi/95/qsort.c +++ b/lib/srfi/95/qsort.c @@ -1,6 +1,6 @@ -/* qsort.c -- quicksort implementation */ -/* Copyright (c) 2009 Alex Shinn. All rights reserved. */ -/* BSD-style license: http://synthcode.com/license.txt */ +/* qsort.c -- quicksort implementation */ +/* Copyright (c) 2009-2010 Alex Shinn. All rights reserved. */ +/* BSD-style license: http://synthcode.com/license.txt */ #include "chibi/eval.h" @@ -147,7 +147,7 @@ static sexp sexp_sort_x (sexp ctx sexp_api_params(self, n), sexp seq, vec = (sexp_truep(sexp_listp(ctx, seq)) ? sexp_list_to_vector(ctx, seq) : seq); if (! sexp_vectorp(vec)) { - res = sexp_type_exception(ctx, "sort: not a vector", vec); + res = sexp_type_exception(ctx, self, SEXP_VECTOR, vec); } else { data = sexp_vector_data(vec); len = sexp_vector_length(vec); @@ -156,9 +156,9 @@ static sexp sexp_sort_x (sexp ctx sexp_api_params(self, n), sexp seq, if (sexp_opcodep(less) && sexp_opcode_inverse(less)) sexp_vector_nreverse(ctx, vec); } else if (! (sexp_procedurep(less) || sexp_opcodep(less))) { - res = sexp_type_exception(ctx, "sort: not a procedure", less); + res = sexp_type_exception(ctx, self, SEXP_PROCEDURE, less); } else if (! (sexp_procedurep(key) || sexp_opcodep(key) || sexp_not(key))) { - res = sexp_type_exception(ctx, "sort: not a procedure", less); + res = sexp_type_exception(ctx, self, SEXP_PROCEDURE, key); } else { res = sexp_qsort_less(ctx, data, 0, len-1, less, key); } diff --git a/lib/srfi/98/env.c b/lib/srfi/98/env.c index 990fec8f..f8e519f3 100644 --- a/lib/srfi/98/env.c +++ b/lib/srfi/98/env.c @@ -1,6 +1,6 @@ -/* env.c -- SRFI-98 environment interface */ -/* Copyright (c) 2009 Alex Shinn. All rights reserved. */ -/* BSD-style license: http://synthcode.com/license.txt */ +/* env.c -- SRFI-98 environment interface */ +/* Copyright (c) 2009-2010 Alex Shinn. All rights reserved. */ +/* BSD-style license: http://synthcode.com/license.txt */ #ifdef __APPLE__ #include @@ -11,15 +11,15 @@ extern char **environ; #include -sexp sexp_get_environment_variable (sexp ctx, sexp str) { +sexp sexp_get_environment_variable (sexp ctx sexp_api_params(self, n), sexp str) { char *cstr; if (! sexp_stringp(str)) - return sexp_type_exception(ctx, "get-environment-variable: not a string", str); + return sexp_type_exception(ctx, self, SEXP_STRING, str); cstr = getenv(sexp_string_data(str)); return cstr ? sexp_c_string(ctx, cstr, -1) : SEXP_FALSE; } -sexp sexp_get_environment_variables (sexp ctx) { +sexp sexp_get_environment_variables (sexp ctx sexp_api_params(self, n)) { int i; char **env, *cname, *cval; sexp_gc_var3(res, name, val); diff --git a/opt/bignum.c b/opt/bignum.c index 37c94c72..588dbde5 100644 --- a/opt/bignum.c +++ b/opt/bignum.c @@ -1,6 +1,6 @@ -/* bignum.c -- bignum support */ -/* Copyright (c) 2009 Alex Shinn. All rights reserved. */ -/* BSD-style license: http://synthcode.com/license.txt */ +/* bignum.c -- bignum support */ +/* Copyright (c) 2009-2010 Alex Shinn. All rights reserved. */ +/* BSD-style license: http://synthcode.com/license.txt */ #define SEXP_INIT_BIGNUM_SIZE 2 @@ -61,8 +61,8 @@ sexp sexp_double_to_bignum (sexp ctx, double f) { int sign; sexp_gc_var3(res, scale, tmp); sexp_gc_preserve3(ctx, res, scale, tmp); - res = sexp_fixnum_to_bignum(ctx, sexp_make_fixnum(0)); - scale = sexp_fixnum_to_bignum(ctx, sexp_make_fixnum(1)); + res = sexp_fixnum_to_bignum(ctx, SEXP_ZERO); + scale = sexp_fixnum_to_bignum(ctx, SEXP_ONE); sign = (f < 0 ? -1 : 1); for (f=fabs(f); f >= 1.0; f=trunc(f/10)) { tmp = sexp_bignum_fxmul(ctx, NULL, scale, double_10s_digit(f), 0); @@ -390,7 +390,7 @@ static sexp quot_step (sexp ctx, sexp *rem, sexp a, sexp b, sexp k, sexp i) { sexp_gc_var5(x, prod, diff, k2, i2); if (sexp_bignum_compare(k, a) > 0) { *rem = a; - return sexp_fixnum_to_bignum(ctx, sexp_make_fixnum(0)); + return sexp_fixnum_to_bignum(ctx, SEXP_ZERO); } sexp_gc_preserve5(ctx, x, prod, diff, k2, i2); k2 = sexp_bignum_double(ctx, k); @@ -418,7 +418,7 @@ sexp sexp_bignum_quot_rem (sexp ctx, sexp *rem, sexp a, sexp b) { b1 = sexp_copy_bignum(ctx, NULL, b, 0); sexp_bignum_sign(b1) = 1; k = sexp_copy_bignum(ctx, NULL, b1, 0); - i = sexp_fixnum_to_bignum(ctx, sexp_make_fixnum(1)); + i = sexp_fixnum_to_bignum(ctx, SEXP_ONE); res = quot_step(ctx, rem, a1, b1, k, i); sexp_bignum_sign(res) = sexp_bignum_sign(a) * sexp_bignum_sign(b); if (sexp_bignum_sign(a) < 0) { @@ -449,7 +449,7 @@ sexp sexp_bignum_expt (sexp ctx, sexp a, sexp b) { sexp_sint_t e = sexp_unbox_fixnum(sexp_fx_abs(b)); sexp_gc_var2(res, acc); sexp_gc_preserve2(ctx, res, acc); - res = sexp_fixnum_to_bignum(ctx, sexp_make_fixnum(1)); + res = sexp_fixnum_to_bignum(ctx, SEXP_ONE); acc = sexp_copy_bignum(ctx, NULL, a, 0); for (; e; e>>=1, acc=sexp_bignum_mul(ctx, NULL, acc, acc)) if (e & 1) @@ -504,7 +504,7 @@ sexp sexp_add (sexp ctx, sexp a, sexp b) { switch ((at << 2) + bt) { case SEXP_NUM_NOT_NOT: case SEXP_NUM_NOT_FIX: case SEXP_NUM_NOT_FLO: case SEXP_NUM_NOT_BIG: - r = sexp_type_exception(ctx, "+: not a number", a); + r = sexp_type_exception(ctx, NULL, SEXP_NUMBER, a); break; case SEXP_NUM_FIX_FIX: r = sexp_fx_add(a, b); /* VM catches this case */ @@ -536,10 +536,10 @@ sexp sexp_sub (sexp ctx, sexp a, sexp b) { switch ((at << 2) + bt) { case SEXP_NUM_NOT_NOT: case SEXP_NUM_NOT_FIX: case SEXP_NUM_NOT_FLO: case SEXP_NUM_NOT_BIG: - r = sexp_type_exception(ctx, "-: not a number", a); + r = sexp_type_exception(ctx, NULL, SEXP_NUMBER, a); break; case SEXP_NUM_FIX_NOT: case SEXP_NUM_FLO_NOT: case SEXP_NUM_BIG_NOT: - r = sexp_type_exception(ctx, "-: not a number", b); + r = sexp_type_exception(ctx, NULL, SEXP_NUMBER, b); break; case SEXP_NUM_FIX_FIX: r = sexp_fx_sub(a, b); /* VM catches this case */ @@ -584,7 +584,7 @@ sexp sexp_mul (sexp ctx, sexp a, sexp b) { switch ((at << 2) + bt) { case SEXP_NUM_NOT_NOT: case SEXP_NUM_NOT_FIX: case SEXP_NUM_NOT_FLO: case SEXP_NUM_NOT_BIG: - r = sexp_type_exception(ctx, "*: not a number", a); + r = sexp_type_exception(ctx, NULL, SEXP_NUMBER, a); break; case SEXP_NUM_FIX_FIX: r = sexp_fx_mul(a, b); @@ -618,10 +618,10 @@ sexp sexp_div (sexp ctx, sexp a, sexp b) { switch ((at << 2) + bt) { case SEXP_NUM_NOT_NOT: case SEXP_NUM_NOT_FIX: case SEXP_NUM_NOT_FLO: case SEXP_NUM_NOT_BIG: - r = sexp_type_exception(ctx, "/: not a number", a); + r = sexp_type_exception(ctx, NULL, SEXP_NUMBER, a); break; case SEXP_NUM_FIX_NOT: case SEXP_NUM_FLO_NOT: case SEXP_NUM_BIG_NOT: - r = sexp_type_exception(ctx, "/: not a number", b); + r = sexp_type_exception(ctx, NULL, SEXP_NUMBER, b); break; case SEXP_NUM_FIX_FIX: f = sexp_fixnum_to_double(a) / sexp_fixnum_to_double(b); @@ -670,16 +670,16 @@ sexp sexp_quotient (sexp ctx, sexp a, sexp b) { switch ((at << 2) + bt) { case SEXP_NUM_NOT_NOT: case SEXP_NUM_NOT_FIX: case SEXP_NUM_NOT_FLO: case SEXP_NUM_NOT_BIG: - r = sexp_type_exception(ctx, "quotient: not a number", a); + r = sexp_type_exception(ctx, NULL, SEXP_FIXNUM, a); break; case SEXP_NUM_FIX_NOT: case SEXP_NUM_FLO_NOT: case SEXP_NUM_BIG_NOT: - r = sexp_type_exception(ctx, "quotient: not a number", b); + r = sexp_type_exception(ctx, NULL, SEXP_FIXNUM, b); break; case SEXP_NUM_FLO_FIX: case SEXP_NUM_FLO_FLO: case SEXP_NUM_FLO_BIG: - r = sexp_type_exception(ctx, "quotient: can't take quotient of inexact", a); + r = sexp_type_exception(ctx, NULL, SEXP_FIXNUM, a); break; case SEXP_NUM_FIX_FLO: case SEXP_NUM_BIG_FLO: - r = sexp_type_exception(ctx, "quotient: can't take quotient of inexact", b); + r = sexp_type_exception(ctx, NULL, SEXP_FIXNUM, b); break; case SEXP_NUM_FIX_FIX: r = sexp_fx_div(a, b); @@ -706,16 +706,16 @@ sexp sexp_remainder (sexp ctx, sexp a, sexp b) { switch ((at << 2) + bt) { case SEXP_NUM_NOT_NOT: case SEXP_NUM_NOT_FIX: case SEXP_NUM_NOT_FLO: case SEXP_NUM_NOT_BIG: - r = sexp_type_exception(ctx, "remainder: not a number", a); + r = sexp_type_exception(ctx, NULL, SEXP_FIXNUM, a); break; case SEXP_NUM_FIX_NOT: case SEXP_NUM_FLO_NOT: case SEXP_NUM_BIG_NOT: - r = sexp_type_exception(ctx, "remainder: not a number", b); + r = sexp_type_exception(ctx, NULL, SEXP_FIXNUM, b); break; case SEXP_NUM_FLO_FIX: case SEXP_NUM_FLO_FLO: case SEXP_NUM_FLO_BIG: - r = sexp_type_exception(ctx, "remainder: can't take quotient of inexact", a); + r = sexp_type_exception(ctx, NULL, SEXP_FIXNUM, a); break; case SEXP_NUM_FIX_FLO: case SEXP_NUM_BIG_FLO: - r = sexp_type_exception(ctx, "remainder: can't take quotient of inexact", b); + r = sexp_type_exception(ctx, NULL, SEXP_FIXNUM, b); break; case SEXP_NUM_FIX_FIX: r = sexp_fx_rem(a, b); @@ -745,7 +745,7 @@ sexp sexp_compare (sexp ctx, sexp a, sexp b) { switch ((at << 2) + bt) { case SEXP_NUM_NOT_NOT: case SEXP_NUM_NOT_FIX: case SEXP_NUM_NOT_FLO: case SEXP_NUM_NOT_BIG: - r = sexp_type_exception(ctx, "compare: not a number", a); + r = sexp_type_exception(ctx, NULL, SEXP_NUMBER, a); break; case SEXP_NUM_FIX_FIX: r = sexp_make_fixnum(sexp_unbox_fixnum(a) - sexp_unbox_fixnum(b)); diff --git a/sexp.c b/sexp.c index c2981ed4..52b77cb6 100644 --- a/sexp.c +++ b/sexp.c @@ -78,14 +78,15 @@ sexp sexp_finalize_port (sexp ctx sexp_api_params(self, n), sexp port) { static struct sexp_struct _sexp_type_specs[] = { _DEF_TYPE(SEXP_OBJECT, 0, 0, 0, 0, 0, 0, 0, 0, "object", NULL), _DEF_TYPE(SEXP_TYPE, 0, 0, 0, 0, 0, sexp_sizeof(type), 0, 0, "type", NULL), - _DEF_TYPE(SEXP_FIXNUM, 0, 0, 0, 0, 0, 0, 0, 0, "fixnum", NULL), + _DEF_TYPE(SEXP_FIXNUM, 0, 0, 0, 0, 0, 0, 0, 0, "integer", NULL), + _DEF_TYPE(SEXP_NUMBER, 0, 0, 0, 0, 0, 0, 0, 0, "number", NULL), _DEF_TYPE(SEXP_CHAR, 0, 0, 0, 0, 0, 0, 0, 0, "char", NULL), _DEF_TYPE(SEXP_BOOLEAN, 0, 0, 0, 0, 0, 0, 0, 0, "boolean", NULL), _DEF_TYPE(SEXP_PAIR, sexp_offsetof(pair, car), 2, 3, 0, 0, sexp_sizeof(pair), 0, 0, "pair", NULL), _DEF_TYPE(SEXP_SYMBOL, sexp_offsetof(symbol, string), 1, 1, 0, 0, sexp_sizeof(symbol), 0, 0, "symbol", NULL), _DEF_TYPE(SEXP_STRING, 0, 0, 0, 0, 0, sexp_sizeof(string)+1, sexp_offsetof(string, length), 1, "string", NULL), _DEF_TYPE(SEXP_VECTOR, sexp_offsetof(vector, data), 0, 0, sexp_offsetof(vector, length), 1, sexp_sizeof(vector), sexp_offsetof(vector, length), sizeof(sexp), "vector", NULL), - _DEF_TYPE(SEXP_FLONUM, 0, 0, 0, 0, 0, sexp_sizeof(flonum), 0, 0, "flonum", NULL), + _DEF_TYPE(SEXP_FLONUM, 0, 0, 0, 0, 0, sexp_sizeof(flonum), 0, 0, "real", NULL), _DEF_TYPE(SEXP_BIGNUM, 0, 0, 0, 0, 0, sexp_sizeof(bignum), sexp_offsetof(bignum, length), sizeof(sexp_uint_t), "bignum", NULL), _DEF_TYPE(SEXP_CPOINTER, sexp_offsetof(cpointer, parent), 1, 0, 0, 0, sexp_sizeof(cpointer), sexp_offsetof(cpointer, length), 1, "cpointer", NULL), _DEF_TYPE(SEXP_IPORT, sexp_offsetof(port, name), 2, 2, 0, 0, sexp_sizeof(port), 0, 0, "input-port", SEXP_FINALIZE_PORT), @@ -136,7 +137,7 @@ sexp sexp_register_type_op (sexp ctx sexp_api_params(self, n), sexp name, if (num_types >= SEXP_MAXIMUM_TYPES) { res = sexp_user_exception(ctx, SEXP_FALSE, "register-type: exceeded maximum type limit", name); } else if (! sexp_stringp(name)) { - res = sexp_type_exception(ctx, "register-type: not a string", name); + res = sexp_type_exception(ctx, self, SEXP_STRING, name); } else { if (num_types >= type_array_size) { len = type_array_size*2; @@ -328,6 +329,17 @@ sexp sexp_make_exception (sexp ctx, sexp kind, sexp message, sexp irritants, return exn; } +sexp sexp_string_cat3 (sexp ctx, char *pre, char *mid, char* suf) { + int plen=strlen(pre), mlen=strlen(mid), slen=strlen(suf); + char *s; + sexp str; + str = sexp_make_string(ctx, sexp_make_fixnum(plen+mlen+slen), SEXP_VOID); + memcpy(s=sexp_string_data(str), pre, plen); + memcpy(s+plen, mid, mlen); + memcpy(s+plen+mlen, suf, slen); + return str; +} + sexp sexp_user_exception (sexp ctx, sexp self, const char *ms, sexp ir) { sexp res; sexp_gc_var3(sym, str, irr); @@ -341,15 +353,32 @@ sexp sexp_user_exception (sexp ctx, sexp self, const char *ms, sexp ir) { return res; } -sexp sexp_type_exception (sexp ctx, const char *message, sexp obj) { - sexp res; - sexp_gc_var3(sym, str, irr); - sexp_gc_preserve3(ctx, sym, str, irr); - res = sexp_make_exception(ctx, sym = sexp_intern(ctx, "type", -1), - str = sexp_c_string(ctx, message, -1), - irr = sexp_list1(ctx, obj), - SEXP_FALSE, SEXP_FALSE); - sexp_gc_release3(ctx); +static sexp type_exception (sexp ctx, sexp self, sexp str, sexp obj, sexp src) { + sexp_gc_var2(res, sym); + sexp_gc_preserve2(ctx, res, sym); + sym = sexp_intern(ctx, "type", -1); + res = sexp_make_exception(ctx, sym, str, obj, self, src); + sexp_exception_irritants(res)=sexp_list1(ctx, sexp_exception_irritants(res)); + sexp_gc_release2(ctx); + return res; +} + +sexp sexp_xtype_exception (sexp ctx, sexp self, const char *msg, sexp obj) { + sexp_gc_var1(res); + sexp_gc_preserve1(ctx, res); + res = sexp_c_string(ctx, msg, -1); + res = type_exception(ctx, self, res, obj, SEXP_FALSE); + sexp_gc_release1(ctx); + return res; +} + +sexp sexp_type_exception (sexp ctx, sexp self, sexp_uint_t type_id, sexp obj) { + sexp_gc_var1(res); + sexp_gc_preserve1(ctx, res); + res = sexp_string_cat3(ctx, "invalid type, expected ", + sexp_type_name_by_index(ctx, type_id), ""); + res = type_exception(ctx, self, res, obj, SEXP_FALSE); + sexp_gc_release1(ctx); return res; } @@ -371,12 +400,17 @@ sexp sexp_print_exception_op (sexp ctx sexp_api_params(self, n), sexp exn, sexp out = sexp_make_output_port(ctx, stderr, SEXP_FALSE); sexp_write_string(ctx, "ERROR", out); if (sexp_exceptionp(exn)) { - if (sexp_procedurep(sexp_exception_procedure(exn))) { - ls = sexp_bytecode_name( - sexp_procedure_code(sexp_exception_procedure(exn))); - if (sexp_symbolp(ls)) { + if (sexp_exception_procedure(exn)) { + if (sexp_procedurep(sexp_exception_procedure(exn))) { + ls = sexp_bytecode_name( + sexp_procedure_code(sexp_exception_procedure(exn))); + if (sexp_symbolp(ls)) { + sexp_write_string(ctx, " in ", out); + sexp_write(ctx, ls, out); + } + } else if (sexp_opcodep(sexp_exception_procedure(exn))) { sexp_write_string(ctx, " in ", out); - sexp_write(ctx, ls, out); + sexp_write_string(ctx, sexp_opcode_name(sexp_exception_procedure(exn)), out); } } if (sexp_pairp(sexp_exception_source(exn))) { @@ -504,7 +538,7 @@ sexp sexp_nreverse_op (sexp ctx sexp_api_params(self, n), sexp ls) { if (ls == SEXP_NULL) { return ls; } else if (! sexp_pairp(ls)) { - return sexp_type_exception(ctx, "not a list", ls); + return sexp_type_exception(ctx, self, SEXP_PAIR, ls); } else { b = ls; a = sexp_cdr(ls); @@ -617,8 +651,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, "bad length", len); - if (clen < 0) return sexp_type_exception(ctx, "negative length", len); + 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); s = sexp_alloc_atomic(ctx, sexp_sizeof(string)+clen+1); if (sexp_exceptionp(s)) return s; sexp_pointer_tag(s) = SEXP_STRING; @@ -640,13 +674,13 @@ 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, "not a string", str); + return sexp_type_exception(ctx, self, SEXP_STRING, str); if (! sexp_fixnump(start)) - return sexp_type_exception(ctx, "not a number", start); + return sexp_type_exception(ctx, self, SEXP_FIXNUM, start); if (sexp_not(end)) end = sexp_make_fixnum(sexp_string_length(str)); if (! sexp_fixnump(end)) - return sexp_type_exception(ctx, "not a number", end); + return sexp_type_exception(ctx, self, SEXP_FIXNUM, end); if ((sexp_unbox_fixnum(start) < 0) || (sexp_unbox_fixnum(start) > sexp_string_length(str)) || (sexp_unbox_fixnum(end) < 0) @@ -667,7 +701,7 @@ sexp sexp_string_concatenate_op (sexp ctx sexp_api_params(self, n), sexp str_ls, char *p, *csep; for (ls=str_ls; sexp_pairp(ls); ls=sexp_cdr(ls), i++) if (! sexp_stringp(sexp_car(ls))) - return sexp_type_exception(ctx, "not a string", sexp_car(ls)); + return sexp_type_exception(ctx, self, SEXP_STRING, sexp_car(ls)); else len += sexp_string_length(sexp_car(ls)); if (sexp_stringp(sep) && ((sep_len=sexp_string_length(sep)) > 0)) { @@ -754,7 +788,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, "string->symbol: not a string", str); + return sexp_type_exception(ctx, self, SEXP_STRING, str); return sexp_intern(ctx, sexp_string_data(str), sexp_string_length(str)); } @@ -907,7 +941,7 @@ 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, "open-input-string: not a string", str); + return sexp_type_exception(ctx, self, SEXP_STRING, str); if (sexp_string_length(str) == 0) in = fopen("/dev/null", "r"); else @@ -978,7 +1012,7 @@ 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, "not an output-port", p); + return sexp_type_exception(ctx, NULL, SEXP_OPORT, p); else if (! sexp_port_openp(p)) return sexp_user_exception(ctx, SEXP_FALSE, "port is closed", p); else { @@ -999,7 +1033,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, "open-input-string: not a string", str); + return sexp_type_exception(ctx, self, SEXP_STRING, str); res = sexp_make_input_port(ctx, NULL, SEXP_FALSE); if (sexp_exceptionp(res)) return res; sexp_port_cookie(res) = str; @@ -1239,7 +1273,7 @@ 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, "write: not an output-port", out); + return sexp_type_exception(ctx, self, SEXP_OPORT, out); else return sexp_write_one(ctx, obj, out); } @@ -1247,7 +1281,7 @@ sexp sexp_write_op (sexp ctx sexp_api_params(self, n), sexp obj, sexp 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, "display: not an output-port", out); + res = sexp_type_exception(ctx, self, SEXP_OPORT, out); else if (sexp_stringp(obj)) sexp_write_string(ctx, sexp_string_data(obj), out); else if (sexp_charp(obj)) @@ -1663,7 +1697,7 @@ sexp sexp_read_op (sexp ctx sexp_api_params(self, n), sexp in) { if (sexp_iportp(in)) res = sexp_read_raw(ctx, in); else - res = sexp_type_exception(ctx, "read: not an input-port", in); + 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) @@ -1686,11 +1720,11 @@ sexp sexp_string_to_number_op (sexp ctx sexp_api_params(self, n), sexp str, sexp int base; sexp_gc_var1(in); if (! sexp_stringp(str)) - return sexp_type_exception(ctx, "string->number: not a string", str); + return sexp_type_exception(ctx, self, SEXP_STRING, str); else if (! sexp_numberp(b)) - return sexp_type_exception(ctx, "string->number: not a number", b); + return sexp_type_exception(ctx, self, SEXP_FIXNUM, b); if (((base=sexp_unbox_fixnum(b)) < 2) || (base > 36)) - return sexp_type_exception(ctx, "string->number: bad base", b); + return sexp_user_exception(ctx, self, "invalid numeric base", b); sexp_gc_preserve1(ctx, in); in = sexp_make_input_string_port(ctx, str); in = ((sexp_string_data(str)[0] == '#') ? diff --git a/tools/genstubs.scm b/tools/genstubs.scm index daf8a684..77acbe26 100755 --- a/tools/genstubs.scm +++ b/tools/genstubs.scm @@ -348,26 +348,6 @@ (thunk) (current-output-port old-out))))) -(define (definite-article x) - (define (vowel? c) - (memv c '(#\a #\e #\i #\o #\u #\A #\E #\I #\O #\U))) - (define (vowel-exception? str) - (member (string-downcase str) - '("european" "ewe" "unicorn" "unicycle" "university" "user"))) - (define (consonant-exception? str) - ;; not "historic" according to elements of style - (member (string-downcase str) - '("heir" "herb" "herbal" "herbivore" "honest" "honor" "hour"))) - (let* ((full-str (with-output-to-string (lambda () (cat x)))) - (i (string-scan #\space full-str)) - (str (if i (substring full-str 0 i) full-str))) - (string-append - (cond - ((equal? str "") "a ") - ((vowel? (string-ref str 0)) (if (vowel-exception? str) "a " "an ")) - (else (if (consonant-exception? str) "an " "a "))) - full-str))) - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; naming @@ -607,6 +587,19 @@ (newline (current-error-port)) (cat "1"))))) +(define (type-id-number type) + (let ((base (type-base type))) + (cond + ((int-type? base) "SEXP_FIXNUM") + ((float-type? base) "SEXP_FLONUM") + ((string-type? base) "SEXP_STRING") + ((eq? base 'char) "SEXP_CHAR") + ((eq? base 'boolean) "SEXP_BOOLEAN") + ((eq? base 'port) "SEXP_IPORT") + ((eq? base 'input-port) "SEXP_IPORT") + ((eq? base 'output-port) "SEXP_OPORT") + (else (type-id-name base))))) + (define (write-validator arg type) (let* ((type (parse-type type)) (array (type-array type)) @@ -617,32 +610,31 @@ ((number? array) (cat " if (!sexp_listp(ctx, " arg ")" " || sexp_unbox_fixnum(sexp_length(" arg ")) != " array ")\n" - " return sexp_type_exception(ctx, \"not a list\", " arg ");\n"))) + " return sexp_type_exception(ctx, self, SEXP_PAIR, " arg ");\n"))) (cat " for (res=" arg "; sexp_pairp(res); res=sexp_cdr(res))\n" " if (! " (lambda () (check-type "sexp_car(res)" type)) ")\n" - " return sexp_type_exception(ctx, \"not a list of " + " return sexp_xtype_exception(ctx, self, \"not a list of " (type-name type) "s\", " arg ");\n") (if (not (number? array)) (cat " if (! sexp_nullp(res))\n" - " return sexp_type_exception(ctx, \"not a list of " + " return sexp_xtype_exception(ctx, self, \"not a list of " (type-name type) "s\", " arg ");\n"))) ((eq? base-type 'port-or-fd) (cat "if (! (sexp_portp(" arg ") || sexp_fixnump(" arg ")))\n" - " return sexp_type_exception(ctx, \"not a port of file descriptor\"," arg ");\n")) + " return sexp_xtype_exception(ctx, self, \"not a port of file descriptor\"," arg ");\n")) ((or (int-type? base-type) (float-type? base-type) (string-type? base-type) (port-type? base-type)) (cat " if (! " (lambda () (check-type arg type)) ")\n" - " return sexp_type_exception(ctx, \"not " - (definite-article (type-name type)) "\", " - arg ");\n")) + " return sexp_type_exception(ctx, self, " + (type-id-number type) ", " arg ");\n")) ((or (assq base-type *types*) (void-pointer-type? type)) (cat " if (! " (lambda () (check-type arg type)) ")\n" - " return sexp_type_exception(ctx, \"not " - (definite-article (type-name type)) "\", " arg ");\n")) + " return sexp_type_exception(ctx, self, " + (type-id-number type) ", " arg ");\n")) ((eq? 'sexp base-type)) ((string-type? type) (write-validator arg 'string)) @@ -1055,7 +1047,7 @@ (define (write-type-getter type name field) (cat "static sexp " (type-getter-name type name field) - " (sexp ctx, sexp x) {\n" + " (sexp ctx sexp_api_params(self, n), sexp x) {\n" (lambda () (write-validator "x" name)) " return " (lambda () @@ -1076,7 +1068,7 @@ (define (write-type-setter type name field) (cat "static sexp " (type-setter-name type name field) - " (sexp ctx, sexp x, sexp v) {\n" + " (sexp ctx sexp_api_params(self, n), sexp x, sexp v) {\n" (lambda () (write-validator "x" name)) (lambda () (write-validator "v" (car field))) " " @@ -1097,7 +1089,7 @@ ((memq 'finalizer: type) => (lambda (x) (cat "static sexp " (generate-stub-name (cadr x)) - " (sexp ctx, sexp x) {\n" + " (sexp ctx sexp_api_params(self, n), sexp x) {\n" " if (sexp_cpointer_freep(x))\n" " " (cadr x) "(sexp_cpointer_value(x));\n" " return SEXP_VOID;\n" @@ -1109,7 +1101,7 @@ (let ((make (caadr x)) (args (cdadr x))) (cat "static sexp " (generate-stub-name make) - " (sexp ctx" + " (sexp ctx sexp_api_params(self, n)" (lambda () (let lp ((ls args) (i 0)) (cond ((pair? ls)