changing type_exception to use self and a type_id

this simplifies and reduces the number of different static strings.
specific error messages are still available with sexp_xtype_exception.

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
+    return sexp_user_exception(ctx, self, "couldn't open input file", path);
-      sexp_user_exception(ctx, SEXP_FALSE, "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<len2) ? len1 : len2);
@@ -2322,22 +2321,22 @@ static sexp sexp_copy_opcode (sexp ctx, sexp op) {
   return res;
 }
 
-sexp sexp_make_opcode (sexp ctx, sexp name, sexp op_class, sexp code,
+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, "make-opcode: not a string", name);
+    res = sexp_type_exception(ctx, self, SEXP_STRING, name);
   else if ((! sexp_fixnump(op_class)) || (sexp_unbox_fixnum(op_class) <= 0)
       || (sexp_unbox_fixnum(op_class) >= 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_type_exception(ctx, self, SEXP_FIXNUM, type);
-  return sexp_make_opcode(ctx, name, sexp_make_fixnum(SEXP_OPC_TYPE_PREDICATE),
+  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));

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);
   }

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);

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
 

lib/chibi/ast.c

@@ -1,11 +1,10 @@
 /*  ast.c -- interface to the Abstract Syntax Tree            */
-/*  Copyright (c) 2009 Alex Shinn.  All rights reserved. */
+/*  Copyright (c) 2009-2010 Alex Shinn.  All rights reserved. */
 /*  BSD-style license: http://synthcode.com/license.txt       */
 
 #include <chibi/eval.h>
 
-static void sexp_define_type_predicate (sexp ctx, sexp env,
+static void sexp_define_type_predicate (sexp ctx, sexp env, char *cname, sexp_uint_t type) {
-                                        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

lib/chibi/disasm.c

@@ -1,5 +1,5 @@
 /*  disasm.c -- optional debugging utilities                  */
-/*  Copyright (c) 2009 Alex Shinn.  All rights reserved. */
+/*  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) {
+static sexp sexp_disasm (sexp ctx sexp_api_params(self, n), sexp bc, sexp out) {
-  return disasm(ctx, bc, out, 0);
+  return disasm(ctx, self, bc, out, 0);
 }
 
 sexp sexp_init_library (sexp ctx sexp_api_params(self, n), sexp env) {

lib/chibi/heap-stats.c

@@ -1,5 +1,5 @@
 /* heap-stats.c -- count or dump heap objects                */
-/* Copyright (c) 2009 Alex Shinn.  All rights reserved. */
+/* Copyright (c) 2009-2010 Alex Shinn.  All rights reserved. */
 /* BSD-style license: http://synthcode.com/license.txt       */
 
 #include <chibi/eval.h>
@@ -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);
 }
 

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))

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) {
+static sexp sexp_make_custom_input_port (sexp ctx, sexp self,
-  return sexp_make_custom_port(ctx, "r", read, SEXP_FALSE, seek, close);
+                                         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) {
+static sexp sexp_make_custom_output_port (sexp ctx, sexp self,
-  sexp res = sexp_make_custom_port(ctx, "w", SEXP_FALSE, write, seek, close);
+                                          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;
 }

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))

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;

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;
 }

lib/srfi/33/bit.c

@@ -1,5 +1,5 @@
 /*  bit.c -- bitwise operators                                */
-/*  Copyright (c) 2009 Alex Shinn.  All rights reserved. */
+/*  Copyright (c) 2009-2010 Alex Shinn.  All rights reserved. */
 /*  BSD-style license: http://synthcode.com/license.txt       */
 
 #include <chibi/eval.h>
@@ -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<<sexp_unbox_fixnum(i)));
 #if SEXP_USE_BIGNUMS
@@ -286,7 +286,7 @@ static sexp sexp_bit_set_p (sexp ctx sexp_api_params(self, n), sexp i, sexp x) {
                                         - pos*sizeof(sexp_uint_t)*CHAR_BIT))));
 #endif
   } else {
-    return sexp_type_exception(ctx, "bit-set?: not an integer", x);
+    return sexp_type_exception(ctx, self, SEXP_FIXNUM, x);
   }
 }
 

lib/srfi/69/hash.c

@@ -1,5 +1,5 @@
 /*  hash.c -- type-general hashing                            */
-/*  Copyright (c) 2009 Alex Shinn.  All rights reserved. */
+/*  Copyright (c) 2009-2010 Alex Shinn.  All rights reserved. */
 /*  BSD-style license: http://synthcode.com/license.txt       */
 
 #include <chibi/eval.h>
@@ -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);
+    return sexp_type_exception(ctx, self, SEXP_STRING, str);
-  else if (! sexp_integerp(bound))
+  else if (! sexp_fixnump(bound))
-    return sexp_type_exception(ctx, "string-hash: not an integer", 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);
+    return sexp_type_exception(ctx, self, SEXP_STRING, str);
-  else if (! sexp_integerp(bound))
+  else if (! sexp_fixnump(bound))
-    return sexp_type_exception(ctx, "string-ci-hash: not an integer", 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))
+  if (! sexp_pointerp(ht))      /* XXXX check the real type id */
-    return sexp_type_exception(ctx, "not a hash-table", ht);
+    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);

lib/srfi/95/qsort.c

@@ -1,5 +1,5 @@
 /*  qsort.c -- quicksort implementation                       */
-/*  Copyright (c) 2009 Alex Shinn.  All rights reserved. */
+/*  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);
     }

lib/srfi/98/env.c

@@ -1,5 +1,5 @@
 /*  env.c -- SRFI-98 environment interface                    */
-/*  Copyright (c) 2009 Alex Shinn.  All rights reserved. */
+/*  Copyright (c) 2009-2010 Alex Shinn.  All rights reserved. */
 /*  BSD-style license: http://synthcode.com/license.txt       */
 
 #ifdef __APPLE__
@@ -11,15 +11,15 @@ extern char **environ;
 
 #include <chibi/eval.h>
 
-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);

opt/bignum.c

@@ -1,5 +1,5 @@
 /*  bignum.c -- bignum support                                */
-/*  Copyright (c) 2009 Alex Shinn.  All rights reserved. */
+/*  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));
+  res = sexp_fixnum_to_bignum(ctx, SEXP_ZERO);
-  scale = sexp_fixnum_to_bignum(ctx, sexp_make_fixnum(1));
+  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));

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) {
+static sexp type_exception (sexp ctx, sexp self, sexp str, sexp obj, sexp src) {
-  sexp res;
+  sexp_gc_var2(res, sym);
-  sexp_gc_var3(sym, str, irr);
+  sexp_gc_preserve2(ctx, res, sym);
-  sexp_gc_preserve3(ctx, sym, str, irr);
+  sym = sexp_intern(ctx, "type", -1);
-  res = sexp_make_exception(ctx, sym = sexp_intern(ctx, "type", -1),
+  res = sexp_make_exception(ctx, sym, str, obj, self, src);
-                            str = sexp_c_string(ctx, message, -1),
+  sexp_exception_irritants(res)=sexp_list1(ctx, sexp_exception_irritants(res));
-                            irr = sexp_list1(ctx, obj),
+  sexp_gc_release2(ctx);
-                            SEXP_FALSE, SEXP_FALSE);
+  return res;
-  sexp_gc_release3(ctx);
+}
+
+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,6 +400,7 @@ 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_exception_procedure(exn)) {
       if (sexp_procedurep(sexp_exception_procedure(exn))) {
         ls = sexp_bytecode_name(
               sexp_procedure_code(sexp_exception_procedure(exn)));
@@ -378,6 +408,10 @@ sexp sexp_print_exception_op (sexp ctx sexp_api_params(self, n), sexp exn, sexp
           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_string(ctx, sexp_opcode_name(sexp_exception_procedure(exn)), out);
+      }
     }
     if (sexp_pairp(sexp_exception_source(exn))) {
       ls = 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 (! sexp_fixnump(len)) return sexp_type_exception(ctx, self, SEXP_FIXNUM, len);
-  if (clen < 0) return sexp_type_exception(ctx, "negative length", 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] == '#') ?

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 "
+       "    return sexp_type_exception(ctx, self, "
-       (definite-article (type-name type)) "\", "
+       (type-id-number type) ", " arg ");\n"))
-       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 "
+       "    return sexp_type_exception(ctx, self, "
-       (definite-article (type-name type)) "\", " arg ");\n"))
+       (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)