mirror of
https://github.com/ashinn/chibi-scheme.git
synced 2025-05-21 06:39:17 +02:00
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.
This commit is contained in:
Alex Shinn
parent
8357b3afaa
commit
d5ddfe6a92
19 changed files with 265 additions and 233 deletions
81
eval.c
81
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<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_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));
|
||||
|
|
|
|||
6
gc.c
6
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);
|
||||
}
|
||||
|
|
|
|||
|
|
@ -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);
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
|
|
|
|||
|
|
@ -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,
|
||||
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
|
||||
|
|
|
|||
|
|
@ -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) {
|
||||
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) {
|
||||
|
|
|
|||
|
|
@ -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);
|
||||
}
|
||||
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
|
|
|
|||
|
|
@ -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;
|
||||
}
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
|
|
|
|||
|
|
@ -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;
|
||||
|
|
|
|||
|
|
@ -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;
|
||||
}
|
||||
|
|
|
|||
|
|
@ -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);
|
||||
}
|
||||
}
|
||||
|
||||
|
|
|
|||
|
|
@ -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);
|
||||
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);
|
||||
|
|
|
|||
|
|
@ -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);
|
||||
}
|
||||
|
|
|
|||
|
|
@ -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);
|
||||
|
|
|
|||
42
opt/bignum.c
42
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));
|
||||
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));
|
||||
|
|
|
|||
92
sexp.c
92
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,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 (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] == '#') ?
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
Loading…
Add table
Reference in a new issue