commit 7e3c12424c595583a28bf2292d6b8d22fbe24f9d
parent 3bd353ef9eedff9c6ad5614d036db34f2629bf57
Author: Andres Navarro <canavarro82@gmail.com>
Date: Tue, 13 Dec 2011 21:04:58 -0300
Refactor: in c style, use all spaces (no tabs), k&r style, 4 space indenting. in kernel style, use 2 space indenting.
Diffstat:
97 files changed, 9494 insertions(+), 9476 deletions(-)
diff --git a/src/kenvironment.h b/src/kenvironment.h
@@ -19,7 +19,7 @@ bool kbinds(klisp_State *K, TValue env, TValue sym);
/* keyed dynamic vars */
/* GC: Assumes parents, key & val are rooted */
TValue kmake_keyed_static_env(klisp_State *K, TValue parent, TValue key,
- TValue val);
+ TValue val);
TValue kget_keyed_static_var(klisp_State *K, TValue env, TValue key);
/* environments with hashtable bindings */
diff --git a/src/kerror.c b/src/kerror.c
@@ -16,7 +16,7 @@
/* GC: assumes all objs passed are rooted */
TValue klispE_new(klisp_State *K, TValue who, TValue cont, TValue msg,
- TValue irritants)
+ TValue irritants)
{
Error *new_error = klispM_new(K, Error);
@@ -33,7 +33,7 @@ TValue klispE_new(klisp_State *K, TValue who, TValue cont, TValue msg,
}
TValue klispE_new_with_errno_irritants(klisp_State *K, const char *service,
- int errnum, TValue irritants)
+ int errnum, TValue irritants)
{
TValue error_description = klispE_describe_errno(K, service, errnum);
krooted_tvs_push(K, error_description);
@@ -58,7 +58,7 @@ void klispE_free(klisp_State *K, Error *error)
void clear_buffers(klisp_State *K)
{
/* These shouldn't cause GC, but just in case do them first,
- an object may be protected in tvs or vars */
+ an object may be protected in tvs or vars */
ks_sclear(K);
ks_tbclear(K);
K->shared_dict = KNIL;
@@ -70,10 +70,10 @@ void clear_buffers(klisp_State *K)
/*
** Throw a simple error obj with:
** {
-** who: current operative/continuation,
-** cont: current continuation,
-** message: msg,
-** irritants: ()
+** who: current operative/continuation,
+** cont: current continuation,
+** message: msg,
+** irritants: ()
** }
*/
/* GC: assumes all objs passed are rooted */
@@ -82,8 +82,8 @@ void klispE_throw_simple(klisp_State *K, char *msg)
TValue error_msg = kstring_new_b_imm(K, msg);
krooted_tvs_push(K, error_msg);
TValue error_obj =
- klispE_new(K, K->next_obj, K->curr_cont, error_msg, KNIL);
- /* clear buffer shouldn't cause GC, but just in case... */
+ klispE_new(K, K->next_obj, K->curr_cont, error_msg, KNIL);
+ /* clear buffer shouldn't cause GC, but just in case... */
krooted_tvs_push(K, error_obj);
clear_buffers(K); /* this pops both error_msg & error_obj */
/* call_cont protects error from gc */
@@ -93,10 +93,10 @@ void klispE_throw_simple(klisp_State *K, char *msg)
/*
** Throw an error obj with:
** {
-** who: current operative/continuation,
-** cont: current continuation,
-** message: msg,
-** irritants: irritants
+** who: current operative/continuation,
+** cont: current continuation,
+** message: msg,
+** irritants: irritants
** }
*/
/* GC: assumes all objs passed are rooted */
@@ -107,8 +107,8 @@ void klispE_throw_with_irritants(klisp_State *K, char *msg, TValue irritants)
TValue error_msg = kstring_new_b_imm(K, msg);
krooted_tvs_push(K, error_msg);
TValue error_obj =
- klispE_new(K, K->next_obj, K->curr_cont, error_msg, irritants);
- /* clear buffer shouldn't cause GC, but just in case... */
+ klispE_new(K, K->next_obj, K->curr_cont, error_msg, irritants);
+ /* clear buffer shouldn't cause GC, but just in case... */
krooted_tvs_push(K, error_obj);
clear_buffers(K); /* this pops both error_msg & error_obj */
/* call_cont protects error from gc */
@@ -119,7 +119,7 @@ void klispE_throw_system_error_with_irritants(
klisp_State *K, const char *service, int errnum, TValue irritants)
{
TValue error_obj = klispE_new_with_errno_irritants(K, service, errnum,
- irritants);
+ irritants);
krooted_tvs_push(K, error_obj);
clear_buffers(K);
kcall_cont(K, K->system_error_cont, error_obj);
@@ -200,7 +200,7 @@ TValue klispE_describe_errno(klisp_State *K, const char *service, int errnum)
{
const char *code = NULL;
int tabsize = sizeof(symbolic_error_codes) /
- sizeof(symbolic_error_codes[0]);
+ sizeof(symbolic_error_codes[0]);
if (0 <= errnum && errnum < tabsize)
code = symbolic_error_codes[errnum];
if (code == NULL)
diff --git a/src/kerror.h b/src/kerror.h
@@ -16,9 +16,9 @@
#include "kpair.h" /* for klist */
TValue klispE_new(klisp_State *K, TValue who, TValue cont, TValue msg,
- TValue irritants);
+ TValue irritants);
TValue klispE_new_with_errno_irritants(klisp_State *K, const char *service,
- int errnum, TValue irritants);
+ int errnum, TValue irritants);
void klispE_free(klisp_State *K, Error *error);
@@ -29,35 +29,35 @@ void klispE_throw_system_error_with_irritants(
klisp_State *K, const char *service, int errnum, TValue irritants);
/* the objects should be rooted */
-#define klispE_new_simple_with_errno_irritants(K__, service__, ...) \
- ({ \
- int errnum__ = errno; \
- TValue ls__ = klist(K__, __VA_ARGS__); \
- krooted_tvs_push(K__, ls__); \
+#define klispE_new_simple_with_errno_irritants(K__, service__, ...) \
+ ({ \
+ int errnum__ = errno; \
+ TValue ls__ = klist(K__, __VA_ARGS__); \
+ krooted_tvs_push(K__, ls__); \
TValue err__ = klispE_new_with_errno_irritants(K__, service__, \
- errnum__, ls__); \
- krooted_tvs_pop(K__); \
- err__; \
+ errnum__, ls__); \
+ krooted_tvs_pop(K__); \
+ err__; \
})
/* evaluates K__ more than once */
/* the objects should be rooted */
-#define klispE_throw_simple_with_irritants(K__, msg__, ...) \
+#define klispE_throw_simple_with_irritants(K__, msg__, ...) \
{ TValue ls__ = klist(K__, __VA_ARGS__); \
- krooted_tvs_push(K__, ls__); \
- /* the pop is implicit in throw_with_irritants */ \
- klispE_throw_with_irritants(K__, msg__, ls__); }
+ krooted_tvs_push(K__, ls__); \
+ /* the pop is implicit in throw_with_irritants */ \
+ klispE_throw_with_irritants(K__, msg__, ls__); }
/* the objects should be rooted */
-#define klispE_throw_errno_with_irritants(K__, service__, ...) \
- { \
- int errnum__ = errno; \
- TValue ls__ = klist(K__, __VA_ARGS__); \
- krooted_tvs_push(K__, ls__); \
+#define klispE_throw_errno_with_irritants(K__, service__, ...) \
+ { \
+ int errnum__ = errno; \
+ TValue ls__ = klist(K__, __VA_ARGS__); \
+ krooted_tvs_push(K__, ls__); \
klispE_throw_system_error_with_irritants(K__, service__, errnum__, ls__); \
- }
+ }
-#define klispE_throw_errno_simple(K__, service__) \
+#define klispE_throw_errno_simple(K__, service__) \
klispE_throw_system_error_with_irritants(K__, service__, errno, KNIL);
TValue klispE_describe_errno(klisp_State *K, const char *service, int errnum);
diff --git a/src/keval.c b/src/keval.c
@@ -43,17 +43,17 @@ void do_eval_ls(klisp_State *K)
/* save the result of last evaluation and continue with next pair */
kset_car(apair, obj);
if (ttisnil(rest)) {
- /* argument evaluation complete */
- /* this is necessary to recreate the cycle in operand list */
- kset_cdr(apair, tail);
- kapply_cc(K, combiner);
+ /* argument evaluation complete */
+ /* this is necessary to recreate the cycle in operand list */
+ kset_cdr(apair, tail);
+ kapply_cc(K, combiner);
} else {
- /* more arguments need to be evaluated */
- /* GC: all objects are rooted at this point */
- TValue new_cont = kmake_continuation(K, kget_cc(K), do_eval_ls, 4,
- rest, env, tail, combiner);
- kset_cc(K, new_cont);
- ktail_eval(K, kcar(rest), env);
+ /* more arguments need to be evaluated */
+ /* GC: all objects are rooted at this point */
+ TValue new_cont = kmake_continuation(K, kget_cc(K), do_eval_ls, 4,
+ rest, env, tail, combiner);
+ kset_cc(K, new_cont);
+ ktail_eval(K, kcar(rest), env);
}
}
@@ -61,8 +61,8 @@ void do_eval_ls(klisp_State *K)
inline void clear_ls_marks(TValue ls)
{
while (ttispair(ls) && kis_marked(ls)) {
- kunmark(ls);
- ls = kcdr(ls);
+ kunmark(ls);
+ ls = kcdr(ls);
}
}
@@ -77,24 +77,24 @@ inline TValue make_arg_ls(klisp_State *K, TValue operands, TValue *tail)
TValue rem_op = kcdr(operands);
while(ttispair(rem_op) && kis_unmarked(rem_op)) {
- TValue new_pair = kcons(K, kcar(rem_op), KNIL);
- kset_mark(rem_op, new_pair);
- kset_cdr(last_pair, new_pair);
- last_pair = new_pair;
- rem_op = kcdr(rem_op);
+ TValue new_pair = kcons(K, kcar(rem_op), KNIL);
+ kset_mark(rem_op, new_pair);
+ kset_cdr(last_pair, new_pair);
+ last_pair = new_pair;
+ rem_op = kcdr(rem_op);
}
krooted_tvs_pop(K);
if (ttispair(rem_op)) {
- /* cyclical list */
- *tail = kget_mark(rem_op);
+ /* cyclical list */
+ *tail = kget_mark(rem_op);
} else if (ttisnil(rem_op)) {
- *tail = KNIL;
+ *tail = KNIL;
} else {
- clear_ls_marks(operands);
- klispE_throw_simple(K, "Not a list in applicative combination");
- return KINERT;
+ clear_ls_marks(operands);
+ klispE_throw_simple(K, "Not a list in applicative combination");
+ return KINERT;
}
clear_ls_marks(operands);
return arg_ls;
@@ -116,38 +116,38 @@ void do_combine(klisp_State *K)
switch(ttype(obj)) {
case K_TAPPLICATIVE: {
- if (ttisnil(operands)) {
- /* no arguments => no evaluation, just call the operative */
- /* NOTE: the while is needed because it may be multiply wrapped */
- while(ttisapplicative(obj))
- obj = tv2app(obj)->underlying;
- ktail_call_si(K, obj, operands, env, si);
- } else if (ttispair(operands)) {
- /* make a copy of the operands (for storing arguments) */
- TValue tail;
- TValue arg_ls = make_arg_ls(K, operands, &tail);
- krooted_tvs_push(K, arg_ls);
- TValue comb_cont = kmake_continuation(K, kget_cc(K), do_combine,
- 3, arg_ls, env, si);
-
- krooted_tvs_pop(K); /* already in cont */
- krooted_tvs_push(K, comb_cont);
- TValue els_cont =
- kmake_continuation(K, comb_cont, do_eval_ls, 4, arg_ls, env,
- tail, tv2app(obj)->underlying);
- kset_cc(K, els_cont);
- krooted_tvs_pop(K);
- ktail_eval(K, kcar(arg_ls), env);
- } else {
- klispE_throw_simple(K, "Not a list in applicative combination");
- return;
- }
+ if (ttisnil(operands)) {
+ /* no arguments => no evaluation, just call the operative */
+ /* NOTE: the while is needed because it may be multiply wrapped */
+ while(ttisapplicative(obj))
+ obj = tv2app(obj)->underlying;
+ ktail_call_si(K, obj, operands, env, si);
+ } else if (ttispair(operands)) {
+ /* make a copy of the operands (for storing arguments) */
+ TValue tail;
+ TValue arg_ls = make_arg_ls(K, operands, &tail);
+ krooted_tvs_push(K, arg_ls);
+ TValue comb_cont = kmake_continuation(K, kget_cc(K), do_combine,
+ 3, arg_ls, env, si);
+
+ krooted_tvs_pop(K); /* already in cont */
+ krooted_tvs_push(K, comb_cont);
+ TValue els_cont =
+ kmake_continuation(K, comb_cont, do_eval_ls, 4, arg_ls, env,
+ tail, tv2app(obj)->underlying);
+ kset_cc(K, els_cont);
+ krooted_tvs_pop(K);
+ ktail_eval(K, kcar(arg_ls), env);
+ } else {
+ klispE_throw_simple(K, "Not a list in applicative combination");
+ return;
+ }
}
case K_TOPERATIVE:
- ktail_call_si(K, obj, operands, env, si);
+ ktail_call_si(K, obj, operands, env, si);
default:
- klispE_throw_simple(K, "Not a combiner in combiner position");
- return;
+ klispE_throw_simple(K, "Not a combiner in combiner position");
+ return;
}
}
@@ -165,19 +165,19 @@ void keval_ofn(klisp_State *K)
switch(ttype(obj)) {
case K_TPAIR: {
- TValue new_cont =
- kmake_continuation(K, kget_cc(K), do_combine, 3, kcdr(obj),
- denv, ktry_get_si(K, obj));
- kset_cc(K, new_cont);
- ktail_eval(K, kcar(obj), denv);
- break;
+ TValue new_cont =
+ kmake_continuation(K, kget_cc(K), do_combine, 3, kcdr(obj),
+ denv, ktry_get_si(K, obj));
+ kset_cc(K, new_cont);
+ ktail_eval(K, kcar(obj), denv);
+ break;
}
case K_TSYMBOL:
- /* error handling happens in kget_binding */
- kapply_cc(K, kget_binding(K, denv, obj));
- break;
+ /* error handling happens in kget_binding */
+ kapply_cc(K, kget_binding(K, denv, obj));
+ break;
default:
- kapply_cc(K, obj);
+ kapply_cc(K, obj);
}
}
diff --git a/src/kgbooleans.c b/src/kgbooleans.c
@@ -58,12 +58,12 @@ void andp(klisp_State *K)
TValue res = KTRUE;
TValue tail = ptree;
while(pairs--) {
- TValue first = kcar(tail);
- tail = kcdr(tail);
- if (kis_false(first)) {
- res = KFALSE;
- break;
- }
+ TValue first = kcar(tail);
+ tail = kcdr(tail);
+ if (kis_false(first)) {
+ res = KFALSE;
+ break;
+ }
}
kapply_cc(K, res);
}
@@ -83,12 +83,12 @@ void orp(klisp_State *K)
TValue res = KFALSE;
TValue tail = ptree;
while(pairs--) {
- TValue first = kcar(tail);
- tail = kcdr(tail);
- if (kis_true(first)) {
- res = KTRUE;
- break;
- }
+ TValue first = kcar(tail);
+ tail = kcdr(tail);
+ if (kis_true(first)) {
+ res = KTRUE;
+ break;
+ }
}
kapply_cc(K, res);
}
@@ -121,41 +121,41 @@ void do_Sandp_Sorp(klisp_State *K)
TValue denv = xparams[3];
if (!ttisboolean(obj)) {
- klispE_throw_simple_with_irritants(K, "expected boolean", 1,
- obj);
- return;
+ klispE_throw_simple_with_irritants(K, "expected boolean", 1,
+ obj);
+ return;
} else if (ttisnil(ls) || tv_equal(obj, term_bool)) {
- /* in both cases the value to be returned is obj:
- if there are no more operands it is obvious otherwise, if
- the termination bool is found:
- $and? returns #f when it finds #f and $or? returns #t when it
- finds #t */
- kapply_cc(K, obj);
+ /* in both cases the value to be returned is obj:
+ if there are no more operands it is obvious otherwise, if
+ the termination bool is found:
+ $and? returns #f when it finds #f and $or? returns #t when it
+ finds #t */
+ kapply_cc(K, obj);
} else {
- TValue first = kcar(ls);
- TValue tail = kcdr(ls);
- /* This is the important part of tail context + bool check */
- if (!ttisnil(tail) || !kis_bool_check_cont(kget_cc(K))) {
- TValue new_cont =
- kmake_continuation(K, kget_cc(K), do_Sandp_Sorp,
- 4, sname, term_bool, tail, denv);
- /*
- ** Mark as a bool checking cont this is needed in the last operand
- ** to allow both tail recursive behaviour and boolean checking.
- ** While it is not necessary if this is not the last operand it
- ** avoids a continuation in the last evaluation of the inner form
- ** in the common use of
- ** ($and?/$or? ($or?/$and? ...) ...)
- */
- kset_bool_check_cont(new_cont);
- kset_cc(K, new_cont);
+ TValue first = kcar(ls);
+ TValue tail = kcdr(ls);
+ /* This is the important part of tail context + bool check */
+ if (!ttisnil(tail) || !kis_bool_check_cont(kget_cc(K))) {
+ TValue new_cont =
+ kmake_continuation(K, kget_cc(K), do_Sandp_Sorp,
+ 4, sname, term_bool, tail, denv);
+ /*
+ ** Mark as a bool checking cont this is needed in the last operand
+ ** to allow both tail recursive behaviour and boolean checking.
+ ** While it is not necessary if this is not the last operand it
+ ** avoids a continuation in the last evaluation of the inner form
+ ** in the common use of
+ ** ($and?/$or? ($or?/$and? ...) ...)
+ */
+ kset_bool_check_cont(new_cont);
+ kset_cc(K, new_cont);
#if KTRACK_SI
- /* put the source info of the list including the element
- that we are about to evaluate */
- kset_source_info(K, new_cont, ktry_get_si(K, ls));
+ /* put the source info of the list including the element
+ that we are about to evaluate */
+ kset_source_info(K, new_cont, ktry_get_si(K, ls));
#endif
- }
- ktail_eval(K, first, denv);
+ }
+ ktail_eval(K, first, denv);
}
}
@@ -176,11 +176,11 @@ void Sandp_Sorp(klisp_State *K)
/* This will work even if ls is empty */
krooted_tvs_push(K, ls);
TValue new_cont = kmake_continuation(K, kget_cc(K), do_Sandp_Sorp, 4,
- sname, term_bool, ls, denv);
+ sname, term_bool, ls, denv);
krooted_tvs_pop(K);
/* there's no need to mark it as bool checking, no evaluation
is done in the dynamic extent of this cont, no need for
- source info either */
+ source info either */
kset_cc(K, new_cont);
kapply_cc(K, knegp(term_bool)); /* pass dummy value to start */
}
@@ -199,7 +199,7 @@ void kinit_booleans_ground_env(klisp_State *K)
/* 4.1.1 boolean? */
add_applicative(K, ground_env, "boolean?", typep, 2, symbol,
- i2tv(K_TBOOLEAN));
+ i2tv(K_TBOOLEAN));
/* 6.1.1 not? */
add_applicative(K, ground_env, "not?", notp, 0);
/* 6.1.2 and? */
diff --git a/src/kgbytevectors.c b/src/kgbytevectors.c
@@ -91,19 +91,19 @@ void make_bytevector(klisp_State *K)
UNUSED(xparams);
UNUSED(denv);
bind_al1tp(K, ptree, "exact integer", keintegerp, tv_s,
- maybe_byte);
+ maybe_byte);
uint8_t fill = 0;
if (get_opt_tpar(K, maybe_byte, "u8", ttisu8)) {
- fill = ivalue(maybe_byte);
+ fill = ivalue(maybe_byte);
}
if (knegativep(tv_s)) {
- klispE_throw_simple(K, "negative size");
- return;
+ klispE_throw_simple(K, "negative size");
+ return;
} else if (!ttisfixint(tv_s)) {
- klispE_throw_simple(K, "size is too big");
- return;
+ klispE_throw_simple(K, "size is too big");
+ return;
}
TValue new_bytevector = kbytevector_new_sf(K, ivalue(tv_s), fill);
kapply_cc(K, new_bytevector);
@@ -134,19 +134,19 @@ void bytevector_u8_ref(klisp_State *K)
UNUSED(xparams);
UNUSED(denv);
bind_2tp(K, ptree, "bytevector", ttisbytevector, bytevector,
- "exact integer", keintegerp, tv_i);
+ "exact integer", keintegerp, tv_i);
if (!ttisfixint(tv_i)) {
- /* TODO show index */
- klispE_throw_simple(K, "index out of bounds");
- return;
+ /* TODO show index */
+ klispE_throw_simple(K, "index out of bounds");
+ return;
}
int32_t i = ivalue(tv_i);
if (i < 0 || i >= kbytevector_size(bytevector)) {
- /* TODO show index */
- klispE_throw_simple(K, "index out of bounds");
- return;
+ /* TODO show index */
+ klispE_throw_simple(K, "index out of bounds");
+ return;
}
TValue res = i2tv(kbytevector_buf(bytevector)[i]);
@@ -163,23 +163,23 @@ void bytevector_u8_setB(klisp_State *K)
UNUSED(xparams);
UNUSED(denv);
bind_3tp(K, ptree, "bytevector", ttisbytevector, bytevector,
- "exact integer", keintegerp, tv_i, "u8", ttisu8, tv_byte);
+ "exact integer", keintegerp, tv_i, "u8", ttisu8, tv_byte);
if (!ttisfixint(tv_i)) {
- /* TODO show index */
- klispE_throw_simple(K, "index out of bounds");
- return;
+ /* TODO show index */
+ klispE_throw_simple(K, "index out of bounds");
+ return;
} else if (kbytevector_immutablep(bytevector)) {
- klispE_throw_simple(K, "immutable bytevector");
- return;
+ klispE_throw_simple(K, "immutable bytevector");
+ return;
}
int32_t i = ivalue(tv_i);
if (i < 0 || i >= kbytevector_size(bytevector)) {
- /* TODO show index */
- klispE_throw_simple(K, "index out of bounds");
- return;
+ /* TODO show index */
+ klispE_throw_simple(K, "index out of bounds");
+ return;
}
kbytevector_buf(bytevector)[i] = (uint8_t) ivalue(tv_byte);
@@ -201,10 +201,10 @@ void bytevector_copy(klisp_State *K)
TValue new_bytevector;
/* the if isn't strictly necessary but it's clearer this way */
if (tv_equal(bytevector, K->empty_bytevector)) {
- new_bytevector = bytevector;
+ new_bytevector = bytevector;
} else {
- new_bytevector = kbytevector_new_bs(K, kbytevector_buf(bytevector),
- kbytevector_size(bytevector));
+ new_bytevector = kbytevector_new_bs(K, kbytevector_buf(bytevector),
+ kbytevector_size(bytevector));
}
kapply_cc(K, new_bytevector);
}
@@ -219,21 +219,21 @@ void bytevector_copyB(klisp_State *K)
UNUSED(xparams);
UNUSED(denv);
bind_2tp(K, ptree, "bytevector", ttisbytevector, bytevector1,
- "bytevector", ttisbytevector, bytevector2);
+ "bytevector", ttisbytevector, bytevector2);
if (kbytevector_immutablep(bytevector2)) {
- klispE_throw_simple(K, "immutable destination bytevector");
- return;
+ klispE_throw_simple(K, "immutable destination bytevector");
+ return;
} else if (kbytevector_size(bytevector1) > kbytevector_size(bytevector2)) {
- klispE_throw_simple(K, "destination bytevector is too small");
- return;
+ klispE_throw_simple(K, "destination bytevector is too small");
+ return;
}
if (!tv_equal(bytevector1, bytevector2) &&
- !tv_equal(bytevector1, K->empty_bytevector)) {
- memcpy(kbytevector_buf(bytevector2),
- kbytevector_buf(bytevector1),
- kbytevector_size(bytevector1));
+ !tv_equal(bytevector1, K->empty_bytevector)) {
+ memcpy(kbytevector_buf(bytevector2),
+ kbytevector_buf(bytevector1),
+ kbytevector_size(bytevector1));
}
kapply_cc(K, KINERT);
}
@@ -249,40 +249,40 @@ void bytevector_copy_partial(klisp_State *K)
UNUSED(xparams);
UNUSED(denv);
bind_3tp(K, ptree, "bytevector", ttisbytevector, bytevector,
- "exact integer", keintegerp, tv_start,
- "exact integer", keintegerp, tv_end);
+ "exact integer", keintegerp, tv_start,
+ "exact integer", keintegerp, tv_end);
if (!ttisfixint(tv_start) || ivalue(tv_start) < 0 ||
- ivalue(tv_start) > kbytevector_size(bytevector)) {
- /* TODO show index */
- klispE_throw_simple(K, "start index out of bounds");
- return;
+ ivalue(tv_start) > kbytevector_size(bytevector)) {
+ /* TODO show index */
+ klispE_throw_simple(K, "start index out of bounds");
+ return;
}
int32_t start = ivalue(tv_start);
if (!ttisfixint(tv_end) || ivalue(tv_end) < 0 ||
- ivalue(tv_end) > kbytevector_size(bytevector)) {
- klispE_throw_simple(K, "end index out of bounds");
- return;
+ ivalue(tv_end) > kbytevector_size(bytevector)) {
+ klispE_throw_simple(K, "end index out of bounds");
+ return;
}
int32_t end = ivalue(tv_end);
if (start > end) {
- /* TODO show indexes */
- klispE_throw_simple(K, "end index is smaller than start index");
- return;
+ /* TODO show indexes */
+ klispE_throw_simple(K, "end index is smaller than start index");
+ return;
}
int32_t size = end - start;
TValue new_bytevector;
/* the if isn't strictly necessary but it's clearer this way */
if (size == 0) {
- new_bytevector = K->empty_bytevector;
+ new_bytevector = K->empty_bytevector;
} else {
- new_bytevector = kbytevector_new_bs(K, kbytevector_buf(bytevector)
- + start, size);
+ new_bytevector = kbytevector_new_bs(K, kbytevector_buf(bytevector)
+ + start, size);
}
kapply_cc(K, new_bytevector);
}
@@ -297,64 +297,64 @@ void bytevector_copy_partialB(klisp_State *K)
UNUSED(xparams);
UNUSED(denv);
bind_al3tp(K, ptree, "bytevector", ttisbytevector, bytevector1,
- "exact integer", keintegerp, tv_start,
- "exact integer", keintegerp, tv_end,
- rest);
+ "exact integer", keintegerp, tv_start,
+ "exact integer", keintegerp, tv_end,
+ rest);
/* XXX: this will send wrong error msgs (bad number of arg) */
bind_2tp(K, rest,
- "bytevector", ttisbytevector, bytevector2,
- "exact integer", keintegerp, tv_start2);
+ "bytevector", ttisbytevector, bytevector2,
+ "exact integer", keintegerp, tv_start2);
if (!ttisfixint(tv_start) || ivalue(tv_start) < 0 ||
- ivalue(tv_start) > kbytevector_size(bytevector1)) {
- /* TODO show index */
- klispE_throw_simple(K, "start index out of bounds");
- return;
+ ivalue(tv_start) > kbytevector_size(bytevector1)) {
+ /* TODO show index */
+ klispE_throw_simple(K, "start index out of bounds");
+ return;
}
int32_t start = ivalue(tv_start);
if (!ttisfixint(tv_end) || ivalue(tv_end) < 0 ||
- ivalue(tv_end) > kbytevector_size(bytevector1)) {
- klispE_throw_simple(K, "end index out of bounds");
- return;
+ ivalue(tv_end) > kbytevector_size(bytevector1)) {
+ klispE_throw_simple(K, "end index out of bounds");
+ return;
}
int32_t end = ivalue(tv_end);
if (start > end) {
- /* TODO show indexes */
- klispE_throw_simple(K, "end index is smaller than start index");
- return;
+ /* TODO show indexes */
+ klispE_throw_simple(K, "end index is smaller than start index");
+ return;
}
int32_t size = end - start;
if (kbytevector_immutablep(bytevector2)) {
- klispE_throw_simple(K, "immutable destination bytevector");
- return;
+ klispE_throw_simple(K, "immutable destination bytevector");
+ return;
}
if (!ttisfixint(tv_start2) || ivalue(tv_start2) < 0 ||
- ivalue(tv_start2) > kbytevector_size(bytevector2)) {
- klispE_throw_simple(K, "to index out of bounds");
- return;
+ ivalue(tv_start2) > kbytevector_size(bytevector2)) {
+ klispE_throw_simple(K, "to index out of bounds");
+ return;
}
int32_t start2 = ivalue(tv_start2);
int64_t end2 = (int64_t) start2 + size;
if ((end2 > INT32_MAX) ||
- (((int32_t) end2) > kbytevector_size(bytevector2))) {
- klispE_throw_simple(K, "not enough space in destination");
- return;
+ (((int32_t) end2) > kbytevector_size(bytevector2))) {
+ klispE_throw_simple(K, "not enough space in destination");
+ return;
}
if (size > 0) {
- memcpy(kbytevector_buf(bytevector2) + start2,
- kbytevector_buf(bytevector1) + start,
- size);
+ memcpy(kbytevector_buf(bytevector2) + start2,
+ kbytevector_buf(bytevector1) + start,
+ size);
}
kapply_cc(K, KINERT);
}
@@ -369,17 +369,17 @@ void bytevector_u8_fillB(klisp_State *K)
UNUSED(xparams);
UNUSED(denv);
bind_2tp(K, ptree, "bytevector", ttisbytevector, bytevector,
- "u8", ttisu8, tv_byte);
+ "u8", ttisu8, tv_byte);
if (kbytevector_immutablep(bytevector)) {
- klispE_throw_simple(K, "immutable bytevector");
- return;
+ klispE_throw_simple(K, "immutable bytevector");
+ return;
}
uint32_t size = kbytevector_size(bytevector);
uint8_t *buf = kbytevector_buf(bytevector);
while(size-- > 0) {
- *buf++ = (uint8_t) ivalue(tv_byte);
+ *buf++ = (uint8_t) ivalue(tv_byte);
}
kapply_cc(K, KINERT);
}
@@ -398,10 +398,10 @@ void bytevector_to_immutable_bytevector(klisp_State *K)
TValue res_bytevector;
if (kbytevector_immutablep(bytevector)) {
/* this includes the empty bytevector */
- res_bytevector = bytevector;
+ res_bytevector = bytevector;
} else {
- res_bytevector = kbytevector_new_bs_imm(K, kbytevector_buf(bytevector),
- kbytevector_size(bytevector));
+ res_bytevector = kbytevector_new_bs_imm(K, kbytevector_buf(bytevector),
+ kbytevector_size(bytevector));
}
kapply_cc(K, res_bytevector);
}
@@ -412,7 +412,7 @@ void kinit_bytevectors_ground_env(klisp_State *K)
TValue ground_env = K->ground_env;
TValue symbol, value;
- /*
+ /*
** This section is not in the report. The bindings here are
** taken from the r7rs scheme draft and should not be considered standard.
** They are provided in the meantime to allow programs to use byte vectors.
@@ -420,12 +420,12 @@ void kinit_bytevectors_ground_env(klisp_State *K)
/* ??.1.1? bytevector? */
add_applicative(K, ground_env, "bytevector?", typep, 2, symbol,
- i2tv(K_TBYTEVECTOR));
+ i2tv(K_TBYTEVECTOR));
/* ??.? immutable-bytevector?, mutable-bytevector? */
add_applicative(K, ground_env, "immutable-bytevector?", ftypep, 2, symbol,
- p2tv(kimmutable_bytevectorp));
+ p2tv(kimmutable_bytevectorp));
add_applicative(K, ground_env, "mutable-bytevector?", ftypep, 2, symbol,
- p2tv(kmutable_bytevectorp));
+ p2tv(kmutable_bytevectorp));
/* ??.1.? bytevector */
add_applicative(K, ground_env, "bytevector", bytevector, 0);
/* ??.1.? list->bytevector */
@@ -441,7 +441,7 @@ void kinit_bytevectors_ground_env(klisp_State *K)
add_applicative(K, ground_env, "bytevector-u8-ref", bytevector_u8_ref, 0);
/* ??.1.5? bytevector-u8-set! */
add_applicative(K, ground_env, "bytevector-u8-set!", bytevector_u8_setB,
- 0);
+ 0);
/* ??.1.?? bytevector-copy */
add_applicative(K, ground_env, "bytevector-copy", bytevector_copy, 0);
@@ -450,17 +450,17 @@ void kinit_bytevectors_ground_env(klisp_State *K)
/* ??.1.?? bytevector-copy-partial */
add_applicative(K, ground_env, "bytevector-copy-partial",
- bytevector_copy_partial, 0);
+ bytevector_copy_partial, 0);
/* ??.1.?? bytevector-copy-partial! */
add_applicative(K, ground_env, "bytevector-copy-partial!",
- bytevector_copy_partialB, 0);
+ bytevector_copy_partialB, 0);
/* ??.?? bytevector-u8-fill! */
add_applicative(K, ground_env, "bytevector-u8-fill!",
- bytevector_u8_fillB, 0);
+ bytevector_u8_fillB, 0);
/* ??.1.?? bytevector->immutable-bytevector */
add_applicative(K, ground_env, "bytevector->immutable-bytevector",
- bytevector_to_immutable_bytevector, 0);
+ bytevector_to_immutable_bytevector, 0);
}
diff --git a/src/kgc.c b/src/kgc.c
@@ -33,9 +33,9 @@
#define maskmarks cast(uint16_t, ~(bitmask(BLACKBIT)|WHITEBITS))
-#define makewhite(g,x) \
- ((x)->gch.gct = cast(uint16_t, \
- ((x)->gch.gct & maskmarks) | klispC_white(g)))
+#define makewhite(g,x) \
+ ((x)->gch.gct = cast(uint16_t, \
+ ((x)->gch.gct & maskmarks) | klispC_white(g)))
#define white2gray(x) reset2bits((x)->gch.gct, WHITE0BIT, WHITE1BIT)
#define black2gray(x) resetbit((x)->gch.gct, BLACKBIT)
@@ -48,24 +48,24 @@
#define markfinalized(u) l_setbit((u)->gct, FINALIZEDBIT)
/* klisp: NOT USED YET */
-#define KEYWEAK bitmask(KEYWEAKBIT)
-#define VALUEWEAK bitmask(VALUEWEAKBIT)
+#define KEYWEAK bitmask(KEYWEAKBIT)
+#define VALUEWEAK bitmask(VALUEWEAKBIT)
/* this one is klisp specific */
-#define markvaluearray(k, a, s) ({ \
- TValue *array_ = (a); \
- int32_t size_ = (s); \
- for(int32_t i_ = 0; i_ < size_; i_++, array_++) { \
- TValue mva_obj_ = *array_; \
- markvalue(k, mva_obj_); \
- }})
+#define markvaluearray(k, a, s) ({ \
+ TValue *array_ = (a); \
+ int32_t size_ = (s); \
+ for(int32_t i_ = 0; i_ < size_; i_++, array_++) { \
+ TValue mva_obj_ = *array_; \
+ markvalue(k, mva_obj_); \
+ }})
#define markvalue(k,o) { checkconsistency(o); \
- if (iscollectable(o) && iswhite(gcvalue(o))) \
- reallymarkobject(k,gcvalue(o)); }
+ if (iscollectable(o) && iswhite(gcvalue(o))) \
+ reallymarkobject(k,gcvalue(o)); }
#define markobject(k,t) { if (iswhite(obj2gco(t))) \
- reallymarkobject(k, obj2gco(t)); }
+ reallymarkobject(k, obj2gco(t)); }
#define setthreshold(g) (g->GCthreshold = (g->estimate/100) * g->gcpause)
@@ -73,7 +73,7 @@
static void removeentry (Node *n) {
klisp_assert(ttisfree(gval(n)));
if (iscollectable(gkey(n)->this))/* dead key; remove it */
- gkey(n)->this = gc2deadkey(gcvalue(gkey(n)->this));
+ gkey(n)->this = gc2deadkey(gcvalue(gkey(n)->this));
}
static void reallymarkobject (klisp_State *K, GCObject *o)
@@ -87,17 +87,17 @@ static void reallymarkobject (klisp_State *K, GCObject *o)
/* klisp: keep this around just in case we add it later */
#if 0
case LUA_TUSERDATA: {
- Table *mt = gco2u(o)->metatable;
- gray2black(o); /* udata are never gray */
- if (mt) markobject(g, mt);
- markobject(g, gco2u(o)->env);
- return;
+ Table *mt = gco2u(o)->metatable;
+ gray2black(o); /* udata are never gray */
+ if (mt) markobject(g, mt);
+ markobject(g, gco2u(o)->env);
+ return;
}
#endif
case K_TBIGRAT: /* the n & d are copied in the bigrat, not pointed to */
case K_TBIGINT:
- gray2black(o); /* bigint & bigrats are never gray */
- break;
+ gray2black(o); /* bigint & bigrats are never gray */
+ break;
case K_TPAIR:
case K_TSYMBOL:
case K_TKEYWORD:
@@ -115,13 +115,13 @@ static void reallymarkobject (klisp_State *K, GCObject *o)
case K_TFPORT:
case K_TMPORT:
case K_TMODULE:
- o->gch.gclist = K->gray;
- K->gray = o;
- break;
+ o->gch.gclist = K->gray;
+ K->gray = o;
+ break;
default:
- /* shouldn't happen */
- fprintf(stderr, "Unknown GCObject type (in GC mark): %d\n", type);
- abort();
+ /* shouldn't happen */
+ fprintf(stderr, "Unknown GCObject type (in GC mark): %d\n", type);
+ abort();
}
}
@@ -131,11 +131,11 @@ static void reallymarkobject (klisp_State *K, GCObject *o)
static void marktmu (global_State *g) {
GCObject *u = g->tmudata;
if (u) {
- do {
- u = u->gch.next;
- makewhite(g, u); /* may be marked, if left from previous GC */
- reallymarkobject(g, u);
- } while (u != g->tmudata);
+ do {
+ u = u->gch.next;
+ makewhite(g, u); /* may be marked, if left from previous GC */
+ reallymarkobject(g, u);
+ } while (u != g->tmudata);
}
}
@@ -146,26 +146,26 @@ size_t klispC_separateudata (lua_State *L, int all) {
GCObject **p = &g->mainthread->next;
GCObject *curr;
while ((curr = *p) != NULL) {
- if (!(iswhite(curr) || all) || isfinalized(gco2u(curr)))
- p = &curr->gch.next; /* don't bother with them */
- else if (fasttm(L, gco2u(curr)->metatable, TM_GC) == NULL) {
- markfinalized(gco2u(curr)); /* don't need finalization */
- p = &curr->gch.next;
- }
- else { /* must call its gc method */
- deadmem += sizeudata(gco2u(curr));
- markfinalized(gco2u(curr));
- *p = curr->gch.next;
- /* link `curr' at the end of `tmudata' list */
- if (g->tmudata == NULL) /* list is empty? */
+ if (!(iswhite(curr) || all) || isfinalized(gco2u(curr)))
+ p = &curr->gch.next; /* don't bother with them */
+ else if (fasttm(L, gco2u(curr)->metatable, TM_GC) == NULL) {
+ markfinalized(gco2u(curr)); /* don't need finalization */
+ p = &curr->gch.next;
+ }
+ else { /* must call its gc method */
+ deadmem += sizeudata(gco2u(curr));
+ markfinalized(gco2u(curr));
+ *p = curr->gch.next;
+ /* link `curr' at the end of `tmudata' list */
+ if (g->tmudata == NULL) /* list is empty? */
/* creates a circular list */
- g->tmudata = curr->gch.next = curr;
- else {
- curr->gch.next = g->tmudata->gch.next;
- g->tmudata->gch.next = curr;
- g->tmudata = curr;
- }
- }
+ g->tmudata = curr->gch.next = curr;
+ else {
+ curr->gch.next = g->tmudata->gch.next;
+ g->tmudata->gch.next = curr;
+ g->tmudata = curr;
+ }
+ }
}
return deadmem;
}
@@ -179,30 +179,30 @@ static int32_t traversetable (klisp_State *K, Table *h) {
int32_t weakvalue = ktable_has_weak_values(tv)? 1 : 0;
if (weakkey || weakvalue) { /* is really weak? */
- h->gct &= ~(KEYWEAK | VALUEWEAK); /* clear bits */
- h->gct |= cast(uint16_t, (weakkey << KEYWEAKBIT) |
- (weakvalue << VALUEWEAKBIT));
- h->gclist = K->weak; /* must be cleared after GC, ... */
- K->weak = obj2gco(h); /* ... so put in the appropriate list */
+ h->gct &= ~(KEYWEAK | VALUEWEAK); /* clear bits */
+ h->gct |= cast(uint16_t, (weakkey << KEYWEAKBIT) |
+ (weakvalue << VALUEWEAKBIT));
+ h->gclist = K->weak; /* must be cleared after GC, ... */
+ K->weak = obj2gco(h); /* ... so put in the appropriate list */
}
if (weakkey && weakvalue) return 1;
if (!weakvalue) {
- i = h->sizearray;
- while (i--)
- markvalue(K, h->array[i]);
+ i = h->sizearray;
+ while (i--)
+ markvalue(K, h->array[i]);
}
i = sizenode(h);
while (i--) {
- Node *n = gnode(h, i);
- klisp_assert(ttype(gkey(n)->this) != K_TDEADKEY ||
- ttisfree(gval(n)));
- if (ttisfree(gval(n)))
- removeentry(n); /* remove empty entries */
- else {
- klisp_assert(!ttisfree(gkey(n)->this));
- if (!weakkey) markvalue(K, gkey(n)->this);
- if (!weakvalue) markvalue(K, gval(n));
- }
+ Node *n = gnode(h, i);
+ klisp_assert(ttype(gkey(n)->this) != K_TDEADKEY ||
+ ttisfree(gval(n)));
+ if (ttisfree(gval(n)))
+ removeentry(n); /* remove empty entries */
+ else {
+ klisp_assert(!ttisfree(gkey(n)->this));
+ if (!weakkey) markvalue(K, gkey(n)->this);
+ if (!weakvalue) markvalue(K, gval(n));
+ }
}
return weakkey || weakvalue;
}
@@ -216,18 +216,18 @@ static void traverseproto (global_State *g, Proto *f) {
int i;
if (f->source) stringmark(f->source);
for (i=0; i<f->sizek; i++) /* mark literals */
- markvalue(g, &f->k[i]);
+ markvalue(g, &f->k[i]);
for (i=0; i<f->sizeupvalues; i++) { /* mark upvalue names */
- if (f->upvalues[i])
- stringmark(f->upvalues[i]);
+ if (f->upvalues[i])
+ stringmark(f->upvalues[i]);
}
for (i=0; i<f->sizep; i++) { /* mark nested protos */
- if (f->p[i])
- markobject(g, f->p[i]);
+ if (f->p[i])
+ markobject(g, f->p[i]);
}
for (i=0; i<f->sizelocvars; i++) { /* mark local-variable names */
- if (f->locvars[i].varname)
- stringmark(f->locvars[i].varname);
+ if (f->locvars[i].varname)
+ stringmark(f->locvars[i].varname);
}
}
@@ -244,7 +244,7 @@ static int32_t propagatemark (klisp_State *K) {
gray2black(o);
/* all types have si pointers */
if (o->gch.si != NULL) {
- markobject(K, o->gch.si);
+ markobject(K, o->gch.si);
}
uint8_t type = o->gch.tt;
@@ -252,95 +252,95 @@ static int32_t propagatemark (klisp_State *K) {
/* case K_TBIGRAT:
case K_TBIGINT: bigints & bigrats are never gray */
case K_TPAIR: {
- Pair *p = cast(Pair *, o);
- markvalue(K, p->mark);
- markvalue(K, p->car);
- markvalue(K, p->cdr);
- return sizeof(Pair);
+ Pair *p = cast(Pair *, o);
+ markvalue(K, p->mark);
+ markvalue(K, p->car);
+ markvalue(K, p->cdr);
+ return sizeof(Pair);
}
case K_TSYMBOL: {
- Symbol *s = cast(Symbol *, o);
- markvalue(K, s->str);
- return sizeof(Symbol);
+ Symbol *s = cast(Symbol *, o);
+ markvalue(K, s->str);
+ return sizeof(Symbol);
}
case K_TKEYWORD: {
- Keyword *k = cast(Keyword *, o);
- markvalue(K, k->str);
- return sizeof(Keyword);
+ Keyword *k = cast(Keyword *, o);
+ markvalue(K, k->str);
+ return sizeof(Keyword);
}
case K_TSTRING: {
- String *s = cast(String *, o);
- markvalue(K, s->mark);
- return sizeof(String) + (s->size + 1 * sizeof(char));
+ String *s = cast(String *, o);
+ markvalue(K, s->mark);
+ return sizeof(String) + (s->size + 1 * sizeof(char));
}
case K_TENVIRONMENT: {
- Environment *e = cast(Environment *, o);
- markvalue(K, e->mark);
- markvalue(K, e->parents);
- markvalue(K, e->bindings);
- markvalue(K, e->keyed_node);
- markvalue(K, e->keyed_parents);
- return sizeof(Environment);
+ Environment *e = cast(Environment *, o);
+ markvalue(K, e->mark);
+ markvalue(K, e->parents);
+ markvalue(K, e->bindings);
+ markvalue(K, e->keyed_node);
+ markvalue(K, e->keyed_parents);
+ return sizeof(Environment);
}
case K_TCONTINUATION: {
- Continuation *c = cast(Continuation *, o);
- markvalue(K, c->mark);
- markvalue(K, c->parent);
- markvalue(K, c->comb);
- markvaluearray(K, c->extra, c->extra_size);
- return sizeof(Continuation) + sizeof(TValue) * c->extra_size;
+ Continuation *c = cast(Continuation *, o);
+ markvalue(K, c->mark);
+ markvalue(K, c->parent);
+ markvalue(K, c->comb);
+ markvaluearray(K, c->extra, c->extra_size);
+ return sizeof(Continuation) + sizeof(TValue) * c->extra_size;
}
case K_TOPERATIVE: {
- Operative *op = cast(Operative *, o);
- markvaluearray(K, op->extra, op->extra_size);
- return sizeof(Operative) + sizeof(TValue) * op->extra_size;
+ Operative *op = cast(Operative *, o);
+ markvaluearray(K, op->extra, op->extra_size);
+ return sizeof(Operative) + sizeof(TValue) * op->extra_size;
}
case K_TAPPLICATIVE: {
- Applicative *a = cast(Applicative *, o);
- markvalue(K, a->underlying);
- return sizeof(Applicative);
+ Applicative *a = cast(Applicative *, o);
+ markvalue(K, a->underlying);
+ return sizeof(Applicative);
}
case K_TENCAPSULATION: {
- Encapsulation *e = cast(Encapsulation *, o);
- markvalue(K, e->key);
- markvalue(K, e->value);
- return sizeof(Encapsulation);
+ Encapsulation *e = cast(Encapsulation *, o);
+ markvalue(K, e->key);
+ markvalue(K, e->value);
+ return sizeof(Encapsulation);
}
case K_TPROMISE: {
- Promise *p = cast(Promise *, o);
- markvalue(K, p->node);
- return sizeof(Promise);
+ Promise *p = cast(Promise *, o);
+ markvalue(K, p->node);
+ return sizeof(Promise);
}
case K_TTABLE: {
- Table *h = cast(Table *, o);
- if (traversetable(K, h)) /* table is weak? */
- black2gray(o); /* keep it gray */
- return sizeof(Table) + sizeof(TValue) * h->sizearray +
- sizeof(Node) * sizenode(h);
+ Table *h = cast(Table *, o);
+ if (traversetable(K, h)) /* table is weak? */
+ black2gray(o); /* keep it gray */
+ return sizeof(Table) + sizeof(TValue) * h->sizearray +
+ sizeof(Node) * sizenode(h);
}
case K_TERROR: {
- Error *e = cast(Error *, o);
- markvalue(K, e->who);
- markvalue(K, e->cont);
- markvalue(K, e->msg);
- markvalue(K, e->irritants);
- return sizeof(Error);
+ Error *e = cast(Error *, o);
+ markvalue(K, e->who);
+ markvalue(K, e->cont);
+ markvalue(K, e->msg);
+ markvalue(K, e->irritants);
+ return sizeof(Error);
}
case K_TBYTEVECTOR: {
- Bytevector *b = cast(Bytevector *, o);
- markvalue(K, b->mark);
- return sizeof(Bytevector) + b->size * sizeof(uint8_t);
+ Bytevector *b = cast(Bytevector *, o);
+ markvalue(K, b->mark);
+ return sizeof(Bytevector) + b->size * sizeof(uint8_t);
}
case K_TFPORT: {
- FPort *p = cast(FPort *, o);
- markvalue(K, p->filename);
- return sizeof(FPort);
+ FPort *p = cast(FPort *, o);
+ markvalue(K, p->filename);
+ return sizeof(FPort);
}
case K_TMPORT: {
- MPort *p = cast(MPort *, o);
- markvalue(K, p->filename);
- markvalue(K, p->buf);
- return sizeof(MPort);
+ MPort *p = cast(MPort *, o);
+ markvalue(K, p->filename);
+ markvalue(K, p->buf);
+ return sizeof(MPort);
}
case K_TVECTOR: {
Vector *v = cast(Vector *, o);
@@ -349,15 +349,15 @@ static int32_t propagatemark (klisp_State *K) {
return sizeof(Vector) + v->sizearray * sizeof(TValue);
}
case K_TMODULE: {
- Module *m = cast(Module *, o);
- markvalue(K, m->env);
- markvalue(K, m->exp_list);
- return sizeof(Module);
+ Module *m = cast(Module *, o);
+ markvalue(K, m->env);
+ markvalue(K, m->exp_list);
+ return sizeof(Module);
}
default:
- fprintf(stderr, "Unknown GCObject type (in GC propagate): %d\n",
- type);
- abort();
+ fprintf(stderr, "Unknown GCObject type (in GC propagate): %d\n",
+ type);
+ abort();
}
}
@@ -381,14 +381,14 @@ static int32_t iscleared (TValue o, int iskey) {
if (!iscollectable(o)) return 0;
#if 0 /* klisp: strings may be mutable... */
if (ttisstring(o)) {
- stringmark(rawtsvalue(o)); /* strings are `values', so are never weak */
- return 0;
+ stringmark(rawtsvalue(o)); /* strings are `values', so are never weak */
+ return 0;
}
#endif
return iswhite(gcvalue(o));
/* klisp: keep around for later
- || (ttisuserdata(o) && (!iskey && isfinalized(uvalue(o))));
+ || (ttisuserdata(o) && (!iskey && isfinalized(uvalue(o))));
*/
}
@@ -398,27 +398,27 @@ static int32_t iscleared (TValue o, int iskey) {
*/
static void cleartable (GCObject *l) {
while (l) {
- Table *h = (Table *) (l);
- int32_t i = h->sizearray;
- klisp_assert(testbit(h->gct, VALUEWEAKBIT) ||
- testbit(h->gct, KEYWEAKBIT));
- if (testbit(h->gct, VALUEWEAKBIT)) {
- while (i--) {
- TValue *o = &h->array[i];
- if (iscleared(*o, 0)) /* value was collected? */
- *o = KFREE; /* remove value */
- }
- }
- i = sizenode(h);
- while (i--) {
- Node *n = gnode(h, i);
- if (!ttisfree(gval(n)) && /* non-empty entry? */
- (iscleared(key2tval(n), 1) || iscleared(gval(n), 0))) {
- gval(n) = KFREE; /* remove value ... */
- removeentry(n); /* remove entry from table */
- }
- }
- l = h->gclist;
+ Table *h = (Table *) (l);
+ int32_t i = h->sizearray;
+ klisp_assert(testbit(h->gct, VALUEWEAKBIT) ||
+ testbit(h->gct, KEYWEAKBIT));
+ if (testbit(h->gct, VALUEWEAKBIT)) {
+ while (i--) {
+ TValue *o = &h->array[i];
+ if (iscleared(*o, 0)) /* value was collected? */
+ *o = KFREE; /* remove value */
+ }
+ }
+ i = sizenode(h);
+ while (i--) {
+ Node *n = gnode(h, i);
+ if (!ttisfree(gval(n)) && /* non-empty entry? */
+ (iscleared(key2tval(n), 1) || iscleared(gval(n), 0))) {
+ gval(n) = KFREE; /* remove value ... */
+ removeentry(n); /* remove entry from table */
+ }
+ }
+ l = h->gclist;
}
}
@@ -427,93 +427,93 @@ static void freeobj (klisp_State *K, GCObject *o) {
uint8_t type = o->gch.tt;
switch (type) {
case K_TBIGINT: {
- mp_int_free(K, (Bigint *)o);
- break;
+ mp_int_free(K, (Bigint *)o);
+ break;
}
case K_TBIGRAT: {
- mp_rat_free(K, (Bigrat *)o);
- break;
+ mp_rat_free(K, (Bigrat *)o);
+ break;
}
case K_TPAIR:
- klispM_free(K, (Pair *)o);
- break;
+ klispM_free(K, (Pair *)o);
+ break;
case K_TSYMBOL:
- /* symbols are in the string/symbol table */
- /* The string will be freed before/after */
- /* symbols with no source info are in the string/symbol table */
- if (ttisnil(ktry_get_si(K, gc2sym(o))))
- K->strt.nuse--;
- klispM_free(K, (Symbol *)o);
- break;
+ /* symbols are in the string/symbol table */
+ /* The string will be freed before/after */
+ /* symbols with no source info are in the string/symbol table */
+ if (ttisnil(ktry_get_si(K, gc2sym(o))))
+ K->strt.nuse--;
+ klispM_free(K, (Symbol *)o);
+ break;
case K_TKEYWORD:
- /* keywords are in the string table */
- /* The string will be freed before/after */
- K->strt.nuse--;
- klispM_free(K, (Keyword *)o);
- break;
+ /* keywords are in the string table */
+ /* The string will be freed before/after */
+ K->strt.nuse--;
+ klispM_free(K, (Keyword *)o);
+ break;
case K_TSTRING:
- /* immutable strings are in the string/symbol table */
- if (kstring_immutablep(gc2str(o)))
- K->strt.nuse--;
- klispM_freemem(K, o, sizeof(String)+o->str.size+1);
- break;
+ /* immutable strings are in the string/symbol table */
+ if (kstring_immutablep(gc2str(o)))
+ K->strt.nuse--;
+ klispM_freemem(K, o, sizeof(String)+o->str.size+1);
+ break;
case K_TENVIRONMENT:
- klispM_free(K, (Environment *)o);
- break;
+ klispM_free(K, (Environment *)o);
+ break;
case K_TCONTINUATION:
- klispM_freemem(K, o, sizeof(Continuation) +
- o->cont.extra_size * sizeof(TValue));
- break;
+ klispM_freemem(K, o, sizeof(Continuation) +
+ o->cont.extra_size * sizeof(TValue));
+ break;
case K_TOPERATIVE:
- klispM_freemem(K, o, sizeof(Operative) +
- o->op.extra_size * sizeof(TValue));
- break;
+ klispM_freemem(K, o, sizeof(Operative) +
+ o->op.extra_size * sizeof(TValue));
+ break;
case K_TAPPLICATIVE:
- klispM_free(K, (Applicative *)o);
- break;
+ klispM_free(K, (Applicative *)o);
+ break;
case K_TENCAPSULATION:
- klispM_free(K, (Encapsulation *)o);
- break;
+ klispM_free(K, (Encapsulation *)o);
+ break;
case K_TPROMISE:
- klispM_free(K, (Promise *)o);
- break;
+ klispM_free(K, (Promise *)o);
+ break;
case K_TTABLE:
- klispH_free(K, (Table *)o);
- break;
+ klispH_free(K, (Table *)o);
+ break;
case K_TERROR:
- klispE_free(K, (Error *)o);
- break;
+ klispE_free(K, (Error *)o);
+ break;
case K_TBYTEVECTOR:
- /* immutable bytevectors are in the string/symbol table */
- if (kbytevector_immutablep(gc2str(o)))
- K->strt.nuse--;
- klispM_freemem(K, o, sizeof(Bytevector)+o->bytevector.size);
- break;
+ /* immutable bytevectors are in the string/symbol table */
+ if (kbytevector_immutablep(gc2str(o)))
+ K->strt.nuse--;
+ klispM_freemem(K, o, sizeof(Bytevector)+o->bytevector.size);
+ break;
case K_TFPORT:
- /* first close the port to free the FILE structure.
- This works even if the port was already closed,
- it is important that this don't throw errors, because
- the mechanism used in error handling would crash at this
- point */
- kclose_port(K, gc2fport(o));
- klispM_free(K, (FPort *)o);
- break;
+ /* first close the port to free the FILE structure.
+ This works even if the port was already closed,
+ it is important that this don't throw errors, because
+ the mechanism used in error handling would crash at this
+ point */
+ kclose_port(K, gc2fport(o));
+ klispM_free(K, (FPort *)o);
+ break;
case K_TMPORT:
- /* memory ports (string & bytevector) don't need to be closed
- explicitly */
- klispM_free(K, (MPort *)o);
- break;
+ /* memory ports (string & bytevector) don't need to be closed
+ explicitly */
+ klispM_free(K, (MPort *)o);
+ break;
case K_TVECTOR:
klispM_freemem(K, o, sizeof(Vector) + sizeof(TValue) * o->vector.sizearray);
break;
case K_TMODULE:
- klispM_free(K, (Module *)o);
- break;
+ klispM_free(K, (Module *)o);
+ break;
default:
- /* shouldn't happen */
- fprintf(stderr, "Unknown GCObject type (in GC free): %d\n",
- type);
- abort();
+ /* shouldn't happen */
+ fprintf(stderr, "Unknown GCObject type (in GC free): %d\n",
+ type);
+ abort();
}
}
@@ -527,17 +527,17 @@ static GCObject **sweeplist (klisp_State *K, GCObject **p, uint32_t count)
GCObject *curr;
int deadmask = otherwhite(K);
while ((curr = *p) != NULL && count-- > 0) {
- if ((curr->gch.gct ^ WHITEBITS) & deadmask) { /* not dead? */
- klisp_assert(!isdead(K, curr) || testbit(curr->gch.gct, FIXEDBIT));
- makewhite(K, curr); /* make it white (for next cycle) */
- p = &curr->gch.next;
- } else { /* must erase `curr' */
- klisp_assert(isdead(K, curr) || deadmask == bitmask(SFIXEDBIT));
- *p = curr->gch.next;
- if (curr == K->rootgc) /* is the first element of the list? */
- K->rootgc = curr->gch.next; /* adjust first */
- freeobj(K, curr);
- }
+ if ((curr->gch.gct ^ WHITEBITS) & deadmask) { /* not dead? */
+ klisp_assert(!isdead(K, curr) || testbit(curr->gch.gct, FIXEDBIT));
+ makewhite(K, curr); /* make it white (for next cycle) */
+ p = &curr->gch.next;
+ } else { /* must erase `curr' */
+ klisp_assert(isdead(K, curr) || deadmask == bitmask(SFIXEDBIT));
+ *p = curr->gch.next;
+ if (curr == K->rootgc) /* is the first element of the list? */
+ K->rootgc = curr->gch.next; /* adjust first */
+ freeobj(K, curr);
+ }
}
return p;
}
@@ -546,12 +546,12 @@ static void checkSizes (klisp_State *K) {
/* check size of string/symbol hash */
if (K->strt.nuse < cast(uint32_t , K->strt.size/4) &&
K->strt.size > MINSTRTABSIZE*2)
- klispS_resize(K, K->strt.size/2); /* table is too big */
+ klispS_resize(K, K->strt.size/2); /* table is too big */
#if 0 /* not used in klisp */
/* check size of buffer */
if (luaZ_sizebuffer(&g->buff) > LUA_MINBUFFER*2) { /* buffer too big? */
- size_t newsize = luaZ_sizebuffer(&g->buff) / 2;
- luaZ_resizebuffer(L, &g->buff, newsize);
+ size_t newsize = luaZ_sizebuffer(&g->buff) / 2;
+ luaZ_resizebuffer(L, &g->buff, newsize);
}
#endif
}
@@ -564,24 +564,24 @@ static void GCTM (lua_State *L) {
const TValue *tm;
/* remove udata from `tmudata' */
if (o == g->tmudata) /* last element? */
- g->tmudata = NULL;
+ g->tmudata = NULL;
else
- g->tmudata->gch.next = udata->uv.next;
+ g->tmudata->gch.next = udata->uv.next;
udata->uv.next = g->mainthread->next; /* return it to `root' list */
g->mainthread->next = o;
makewhite(g, o);
tm = fasttm(L, udata->uv.metatable, TM_GC);
if (tm != NULL) {
- lu_byte oldah = L->allowhook;
- lu_mem oldt = g->GCthreshold;
- L->allowhook = 0; /* stop debug hooks during GC tag method */
- g->GCthreshold = 2*g->totalbytes; /* avoid GC steps */
- setobj2s(L, L->top, tm);
- setuvalue(L, L->top+1, udata);
- L->top += 2;
- luaD_call(L, L->top - 2, 0);
- L->allowhook = oldah; /* restore hooks */
- g->GCthreshold = oldt; /* restore threshold */
+ lu_byte oldah = L->allowhook;
+ lu_mem oldt = g->GCthreshold;
+ L->allowhook = 0; /* stop debug hooks during GC tag method */
+ g->GCthreshold = 2*g->totalbytes; /* avoid GC steps */
+ setobj2s(L, L->top, tm);
+ setuvalue(L, L->top+1, udata);
+ L->top += 2;
+ luaD_call(L, L->top - 2, 0);
+ L->allowhook = oldah; /* restore hooks */
+ g->GCthreshold = oldt; /* restore threshold */
}
}
@@ -591,7 +591,7 @@ static void GCTM (lua_State *L) {
*/
void klispC_callGCTM (lua_State *L) {
while (G(L)->tmudata)
- GCTM(L);
+ GCTM(L);
}
#endif
@@ -600,11 +600,11 @@ void klispC_callGCTM (lua_State *L) {
void klispC_freeall (klisp_State *K) {
/* mask to collect all elements */
K->currentwhite = WHITEBITS | bitmask(SFIXEDBIT); /* in klisp this may not be
- necessary */
+ necessary */
sweepwholelist(K, &K->rootgc);
/* free all keyword/symbol/string/bytevectors lists */
for (int32_t i = 0; i < K->strt.size; i++)
- sweepwholelist(K, &K->strt.hash[i]);
+ sweepwholelist(K, &K->strt.hash[i]);
}
@@ -662,7 +662,7 @@ static void markroot (klisp_State *K) {
/* the area protecting variables is an array of type TValue *[] */
TValue **ptr = K->rooted_vars_buf;
for (int i = 0, top = K->rooted_vars_top; i < top; i++, ptr++) {
- markvalue(K, **ptr);
+ markvalue(K, **ptr);
}
K->gcstate = GCSpropagate;
@@ -703,52 +703,52 @@ static void atomic (klisp_State *K) {
static int32_t singlestep (klisp_State *K) {
switch (K->gcstate) {
case GCSpause: {
- markroot(K); /* start a new collection */
- return 0;
+ markroot(K); /* start a new collection */
+ return 0;
}
case GCSpropagate: {
- if (K->gray)
- return propagatemark(K);
- else { /* no more `gray' objects */
- atomic(K); /* finish mark phase */
- return 0;
- }
+ if (K->gray)
+ return propagatemark(K);
+ else { /* no more `gray' objects */
+ atomic(K); /* finish mark phase */
+ return 0;
+ }
}
case GCSsweepstring: {
- uint32_t old = K->totalbytes;
- sweepwholelist(K, &K->strt.hash[K->sweepstrgc++]);
- if (K->sweepstrgc >= K->strt.size) /* nothing more to sweep? */
- K->gcstate = GCSsweep; /* end sweep-string phase */
- klisp_assert(old >= K->totalbytes);
- K->estimate -= old - K->totalbytes;
- return GCSWEEPCOST;
+ uint32_t old = K->totalbytes;
+ sweepwholelist(K, &K->strt.hash[K->sweepstrgc++]);
+ if (K->sweepstrgc >= K->strt.size) /* nothing more to sweep? */
+ K->gcstate = GCSsweep; /* end sweep-string phase */
+ klisp_assert(old >= K->totalbytes);
+ K->estimate -= old - K->totalbytes;
+ return GCSWEEPCOST;
}
case GCSsweep: {
- uint32_t old = K->totalbytes;
- K->sweepgc = sweeplist(K, K->sweepgc, GCSWEEPMAX);
- if (*K->sweepgc == NULL) { /* nothing more to sweep? */
- checkSizes(K);
- K->gcstate = GCSfinalize; /* end sweep phase */
- }
- klisp_assert(old >= K->totalbytes);
- K->estimate -= old - K->totalbytes;
- return GCSWEEPMAX*GCSWEEPCOST;
+ uint32_t old = K->totalbytes;
+ K->sweepgc = sweeplist(K, K->sweepgc, GCSWEEPMAX);
+ if (*K->sweepgc == NULL) { /* nothing more to sweep? */
+ checkSizes(K);
+ K->gcstate = GCSfinalize; /* end sweep phase */
+ }
+ klisp_assert(old >= K->totalbytes);
+ K->estimate -= old - K->totalbytes;
+ return GCSWEEPMAX*GCSWEEPCOST;
}
case GCSfinalize: {
#if 0 /* keep around */
- if (g->tmudata) {
- GCTM(L);
- if (g->estimate > GCFINALIZECOST)
- g->estimate -= GCFINALIZECOST;
- return GCFINALIZECOST;
- }
- else {
+ if (g->tmudata) {
+ GCTM(L);
+ if (g->estimate > GCFINALIZECOST)
+ g->estimate -= GCFINALIZECOST;
+ return GCFINALIZECOST;
+ }
+ else {
#endif
- K->gcstate = GCSpause; /* end collection */
- K->gcdept = 0;
- return 0;
+ K->gcstate = GCSpause; /* end collection */
+ K->gcdept = 0;
+ return 0;
#if 0
- }
+ }
#endif
}
default: klisp_assert(0); return 0;
@@ -760,69 +760,69 @@ void klispC_step (klisp_State *K) {
int32_t lim = (GCSTEPSIZE/100) * K->gcstepmul;
if (lim == 0)
- lim = (UINT32_MAX-1)/2; /* no limit */
+ lim = (UINT32_MAX-1)/2; /* no limit */
K->gcdept += K->totalbytes - K->GCthreshold;
do {
- lim -= singlestep(K);
- if (K->gcstate == GCSpause)
- break;
+ lim -= singlestep(K);
+ if (K->gcstate == GCSpause)
+ break;
} while (lim > 0);
if (K->gcstate != GCSpause) {
- if (K->gcdept < GCSTEPSIZE) {
- K->GCthreshold = K->totalbytes + GCSTEPSIZE;
- /* - lim/g->gcstepmul;*/
- } else {
- K->gcdept -= GCSTEPSIZE;
- K->GCthreshold = K->totalbytes;
- }
+ if (K->gcdept < GCSTEPSIZE) {
+ K->GCthreshold = K->totalbytes + GCSTEPSIZE;
+ /* - lim/g->gcstepmul;*/
+ } else {
+ K->gcdept -= GCSTEPSIZE;
+ K->GCthreshold = K->totalbytes;
+ }
} else {
- klisp_assert(K->totalbytes >= K->estimate);
- setthreshold(K);
+ klisp_assert(K->totalbytes >= K->estimate);
+ setthreshold(K);
}
}
void klispC_fullgc (klisp_State *K) {
- if (K->gcstate <= GCSpropagate) {
- /* reset sweep marks to sweep all elements (returning them to white) */
- K->sweepstrgc = 0;
- K->sweepgc = &K->rootgc;
- /* reset other collector lists */
- K->gray = NULL;
- K->grayagain = NULL;
- K->weak = NULL;
- K->gcstate = GCSsweepstring;
- }
- klisp_assert(K->gcstate != GCSpause && K->gcstate != GCSpropagate);
- /* finish any pending sweep phase */
- while (K->gcstate != GCSfinalize) {
- klisp_assert(K->gcstate == GCSsweepstring || K->gcstate == GCSsweep);
- singlestep(K);
- }
- markroot(K);
- while (K->gcstate != GCSpause) {
- singlestep(K);
- }
- setthreshold(K);
+ if (K->gcstate <= GCSpropagate) {
+ /* reset sweep marks to sweep all elements (returning them to white) */
+ K->sweepstrgc = 0;
+ K->sweepgc = &K->rootgc;
+ /* reset other collector lists */
+ K->gray = NULL;
+ K->grayagain = NULL;
+ K->weak = NULL;
+ K->gcstate = GCSsweepstring;
+ }
+ klisp_assert(K->gcstate != GCSpause && K->gcstate != GCSpropagate);
+ /* finish any pending sweep phase */
+ while (K->gcstate != GCSfinalize) {
+ klisp_assert(K->gcstate == GCSsweepstring || K->gcstate == GCSsweep);
+ singlestep(K);
+ }
+ markroot(K);
+ while (K->gcstate != GCSpause) {
+ singlestep(K);
+ }
+ setthreshold(K);
}
/* TODO: make all code using mutation to call these,
- this is actually the only thing that is missing for an incremental
- garbage collector!
- IMPORTANT: a call to maybe a different but similar function should be
- made before assigning to a GC guarded variable, or pushed in a GC
-guarded stack! */
+ this is actually the only thing that is missing for an incremental
+ garbage collector!
+ IMPORTANT: a call to maybe a different but similar function should be
+ made before assigning to a GC guarded variable, or pushed in a GC
+ guarded stack! */
void klispC_barrierf (klisp_State *K, GCObject *o, GCObject *v) {
klisp_assert(isblack(o) && iswhite(v) && !isdead(K, v) && !isdead(K, o));
klisp_assert(K->gcstate != GCSfinalize && K->gcstate != GCSpause);
klisp_assert(o->gch.tt != K_TTABLE);
/* must keep invariant? */
if (K->gcstate == GCSpropagate)
- reallymarkobject(K, v); /* restore invariant */
+ reallymarkobject(K, v); /* restore invariant */
else /* don't mind */
- makewhite(K, o); /* mark as white just to avoid other barriers */
+ makewhite(K, o); /* mark as white just to avoid other barriers */
}
void klispC_barrierback (klisp_State *K, Table *t) {
diff --git a/src/kgc.h b/src/kgc.h
@@ -25,7 +25,7 @@
#define GCSfinalize 4
/* NOTE: unlike in lua the gc flags have 16 bits in klisp,
- so resetbits is slightly different */
+ so resetbits is slightly different */
/*
** some useful bit tricks
@@ -69,8 +69,8 @@
#define WHITEBITS bit2mask(WHITE0BIT, WHITE1BIT)
-#define iswhite(x) test2bits((x)->gch.gct, WHITE0BIT, WHITE1BIT)
-#define isblack(x) testbit((x)->gch.gct, BLACKBIT)
+#define iswhite(x) test2bits((x)->gch.gct, WHITE0BIT, WHITE1BIT)
+#define isblack(x) testbit((x)->gch.gct, BLACKBIT)
#define isgray(x) (!isblack(x) && !iswhite(x))
@@ -85,23 +85,23 @@
#define klispC_white(K) cast(uint16_t, (K)->currentwhite & WHITEBITS)
-#define klispC_checkGC(K) { \
- if (K->totalbytes >= K->GCthreshold) \
- klispC_step(K); }
+#define klispC_checkGC(K) { \
+ if (K->totalbytes >= K->GCthreshold) \
+ klispC_step(K); }
-#define klispC_barrier(K,p,v) { if (valiswhite(v) && isblack(obj2gco(p))) \
- klispC_barrierf(K,obj2gco(p),gcvalue(v)); }
+#define klispC_barrier(K,p,v) { if (valiswhite(v) && isblack(obj2gco(p))) \
+ klispC_barrierf(K,obj2gco(p),gcvalue(v)); }
-#define klispC_barriert(K,t,v) { if (valiswhite(v) && isblack(obj2gco(t))) \
- klispC_barrierback(K,t); }
+#define klispC_barriert(K,t,v) { if (valiswhite(v) && isblack(obj2gco(t))) \
+ klispC_barrierback(K,t); }
-#define klispC_objbarrier(K,p,o) \
- { if (iswhite(obj2gco(o)) && isblack(obj2gco(p))) \
- klispC_barrierf(K,obj2gco(p),obj2gco(o)); }
+#define klispC_objbarrier(K,p,o) \
+ { if (iswhite(obj2gco(o)) && isblack(obj2gco(p))) \
+ klispC_barrierf(K,obj2gco(p),obj2gco(o)); }
-#define klispC_objbarriert(K,t,o) \
- { if (iswhite(obj2gco(o)) && isblack(obj2gco(t))) klispC_barrierback(K,t); }
+#define klispC_objbarriert(K,t,o) \
+ { if (iswhite(obj2gco(o)) && isblack(obj2gco(t))) klispC_barrierback(K,t); }
/* size_t klispC_separateudata (klisp_State *K, int all); */
/* void klispC_callGCTM (klisp_State *K); */
diff --git a/src/kgchars.c b/src/kgchars.c
@@ -56,15 +56,15 @@ void kinteger_to_char(klisp_State *K)
bind_1tp(K, ptree, "exact integer", ttiseinteger, itv);
if (ttisbigint(itv)) {
- klispE_throw_simple(K, "integer out of ASCII range [0 - 127]");
- return;
+ klispE_throw_simple(K, "integer out of ASCII range [0 - 127]");
+ return;
}
int32_t i = ivalue(itv);
/* for now only allow ASCII */
if (i < 0 || i > 127) {
- klispE_throw_simple(K, "integer out of ASCII range [0 - 127]");
- return;
+ klispE_throw_simple(K, "integer out of ASCII range [0 - 127]");
+ return;
}
kapply_cc(K, ch2tv((char) i));
}
@@ -114,11 +114,11 @@ void char_digitp(klisp_State *K)
int base = 10; /* default */
if (get_opt_tpar(K, basetv, "base [2-36]", ttisbase)) {
- base = ivalue(basetv);
+ base = ivalue(basetv);
}
char ch = tolower(chvalue(chtv));
bool b = (isdigit(ch) && (ch - '0') < base) ||
- (isalpha(ch) && (ch - 'a' + 10) < base);
+ (isalpha(ch) && (ch - 'a' + 10) < base);
kapply_cc(K, b2tv(b));
}
@@ -136,19 +136,19 @@ void char_to_digit(klisp_State *K)
int base = 10; /* default */
if (get_opt_tpar(K, basetv, "base [2-36]", ttisbase)) {
- base = ivalue(basetv);
+ base = ivalue(basetv);
}
char ch = tolower(chvalue(chtv));
int digit = 0;
if (isdigit(ch) && (ch - '0') < base)
- digit = ch - '0';
+ digit = ch - '0';
else if (isalpha(ch) && (ch - 'a' + 10) < base)
- digit = ch - 'a' + 10;
+ digit = ch - 'a' + 10;
else {
- klispE_throw_simple_with_irritants(K, "Not a digit in this base",
- 2, ch2tv(ch), i2tv(base));
- return;
+ klispE_throw_simple_with_irritants(K, "Not a digit in this base",
+ 2, ch2tv(ch), i2tv(base));
+ return;
}
kapply_cc(K, i2tv(digit));
}
@@ -167,19 +167,19 @@ void digit_to_char(klisp_State *K)
int base = 10; /* default */
if (get_opt_tpar(K, basetv, "base [2-36]", ttisbase)) {
- base = ivalue(basetv);
+ base = ivalue(basetv);
}
if (ttisbigint(digittv) || ivalue(digittv) < 0 ||
- ivalue(digittv) >= base) {
- klispE_throw_simple_with_irritants(K, "Not a digit in this base",
- 2, digittv, i2tv(base));
- return;
+ ivalue(digittv) >= base) {
+ klispE_throw_simple_with_irritants(K, "Not a digit in this base",
+ 2, digittv, i2tv(base));
+ return;
}
int digit = ivalue(digittv);
char ch = digit <= 9?
- '0' + digit :
- 'a' + (digit - 10);
+ '0' + digit :
+ 'a' + (digit - 10);
kapply_cc(K, ch2tv(ch));
}
@@ -198,59 +198,59 @@ void kinit_chars_ground_env(klisp_State *K)
/* 14.1.1? char? */
add_applicative(K, ground_env, "char?", typep, 2, symbol,
- i2tv(K_TCHAR));
+ i2tv(K_TCHAR));
/* 14.1.2? char-alphabetic?, char-numeric?, char-whitespace? */
/* unlike in r5rs these take an arbitrary number of chars
(even cyclical list) */
add_applicative(K, ground_env, "char-alphabetic?", ftyped_predp, 3,
- symbol, p2tv(kcharp), p2tv(kchar_alphabeticp));
+ symbol, p2tv(kcharp), p2tv(kchar_alphabeticp));
add_applicative(K, ground_env, "char-numeric?", ftyped_predp, 3,
- symbol, p2tv(kcharp), p2tv(kchar_numericp));
+ symbol, p2tv(kcharp), p2tv(kchar_numericp));
add_applicative(K, ground_env, "char-whitespace?", ftyped_predp, 3,
- symbol, p2tv(kcharp), p2tv(kchar_whitespacep));
+ symbol, p2tv(kcharp), p2tv(kchar_whitespacep));
/* 14.1.3? char-upper-case?, char-lower-case? */
/* unlike in r5rs these take an arbitrary number of chars
(even cyclical list) */
add_applicative(K, ground_env, "char-upper-case?", ftyped_predp, 3,
- symbol, p2tv(kcharp), p2tv(kchar_upper_casep));
+ symbol, p2tv(kcharp), p2tv(kchar_upper_casep));
add_applicative(K, ground_env, "char-lower-case?", ftyped_predp, 3,
- symbol, p2tv(kcharp), p2tv(kchar_lower_casep));
+ symbol, p2tv(kcharp), p2tv(kchar_lower_casep));
/* 14.1.4? char->integer, integer->char */
add_applicative(K, ground_env, "char->integer", kchar_to_integer, 0);
add_applicative(K, ground_env, "integer->char", kinteger_to_char, 0);
/* 14.1.4? char-upcase, char-downcase, char-titlecase, char-foldcase */
add_applicative(K, ground_env, "char-upcase", kchar_change_case, 1,
- p2tv(toupper));
+ p2tv(toupper));
add_applicative(K, ground_env, "char-downcase", kchar_change_case, 1,
- p2tv(tolower));
+ p2tv(tolower));
add_applicative(K, ground_env, "char-titlecase", kchar_change_case, 1,
- p2tv(toupper));
+ p2tv(toupper));
add_applicative(K, ground_env, "char-foldcase", kchar_change_case, 1,
- p2tv(tolower));
+ p2tv(tolower));
/* 14.2.1? char=? */
add_applicative(K, ground_env, "char=?", ftyped_bpredp, 3,
- symbol, p2tv(kcharp), p2tv(kchar_eqp));
+ symbol, p2tv(kcharp), p2tv(kchar_eqp));
/* 14.2.2? char<?, char<=?, char>?, char>=? */
add_applicative(K, ground_env, "char<?", ftyped_bpredp, 3,
- symbol, p2tv(kcharp), p2tv(kchar_ltp));
+ symbol, p2tv(kcharp), p2tv(kchar_ltp));
add_applicative(K, ground_env, "char<=?", ftyped_bpredp, 3,
- symbol, p2tv(kcharp), p2tv(kchar_lep));
+ symbol, p2tv(kcharp), p2tv(kchar_lep));
add_applicative(K, ground_env, "char>?", ftyped_bpredp, 3,
- symbol, p2tv(kcharp), p2tv(kchar_gtp));
+ symbol, p2tv(kcharp), p2tv(kchar_gtp));
add_applicative(K, ground_env, "char>=?", ftyped_bpredp, 3,
- symbol, p2tv(kcharp), p2tv(kchar_gep));
+ symbol, p2tv(kcharp), p2tv(kchar_gep));
/* 14.2.3? char-ci=? */
add_applicative(K, ground_env, "char-ci=?", ftyped_bpredp, 3,
- symbol, p2tv(kcharp), p2tv(kchar_ci_eqp));
+ symbol, p2tv(kcharp), p2tv(kchar_ci_eqp));
/* 14.2.4? char-ci<?, char-ci<=?, char-ci>?, char-ci>=? */
add_applicative(K, ground_env, "char-ci<?", ftyped_bpredp, 3,
- symbol, p2tv(kcharp), p2tv(kchar_ci_ltp));
+ symbol, p2tv(kcharp), p2tv(kchar_ci_ltp));
add_applicative(K, ground_env, "char-ci<=?", ftyped_bpredp, 3,
- symbol, p2tv(kcharp), p2tv(kchar_ci_lep));
+ symbol, p2tv(kcharp), p2tv(kchar_ci_lep));
add_applicative(K, ground_env, "char-ci>?", ftyped_bpredp, 3,
- symbol, p2tv(kcharp), p2tv(kchar_ci_gtp));
+ symbol, p2tv(kcharp), p2tv(kchar_ci_gtp));
add_applicative(K, ground_env, "char-ci>=?", ftyped_bpredp, 3,
- symbol, p2tv(kcharp), p2tv(kchar_ci_gep));
+ symbol, p2tv(kcharp), p2tv(kchar_ci_gep));
/* 14.2.? char-digit?, char->digit, digit->char */
add_applicative(K, ground_env, "char-digit?", char_digitp, 0);
add_applicative(K, ground_env, "char->digit", char_to_digit, 0);
diff --git a/src/kgcombiners.c b/src/kgcombiners.c
@@ -63,16 +63,16 @@ void Svau(klisp_State *K)
TValue new_op = kmake_operative(K, do_vau, 4, vptree, vpenv, vbody, denv);
- #if KTRACK_SI
+#if KTRACK_SI
/* save as source code info the info from the expression whose evaluation
got us here */
TValue si = kget_csi(K);
if (!ttisnil(si)) {
- krooted_tvs_push(K, new_op);
- kset_source_info(K, new_op, si);
- krooted_tvs_pop(K);
+ krooted_tvs_push(K, new_op);
+ kset_source_info(K, new_op, si);
+ krooted_tvs_pop(K);
}
- #endif
+#endif
krooted_tvs_pop(K);
krooted_tvs_pop(K);
@@ -107,29 +107,29 @@ void do_vau(klisp_State *K)
match(K, env, op_ptree, ptree);
if (!ttisignore(penv))
- kadd_binding(K, env, penv, denv);
+ kadd_binding(K, env, penv, denv);
/* keep env in stack in case a cont has to be constructed */
if (ttisnil(body)) {
- krooted_tvs_pop(K);
- kapply_cc(K, KINERT);
+ krooted_tvs_pop(K);
+ kapply_cc(K, KINERT);
} else {
- /* this is needed because seq continuation doesn't check for
- nil sequence */
- TValue tail = kcdr(body);
- if (ttispair(tail)) {
- TValue new_cont = kmake_continuation(K, kget_cc(K),
- do_seq, 2, tail, env);
- kset_cc(K, new_cont);
+ /* this is needed because seq continuation doesn't check for
+ nil sequence */
+ TValue tail = kcdr(body);
+ if (ttispair(tail)) {
+ TValue new_cont = kmake_continuation(K, kget_cc(K),
+ do_seq, 2, tail, env);
+ kset_cc(K, new_cont);
#if KTRACK_SI
- /* put the source info of the list including the element
- that we are about to evaluate */
- kset_source_info(K, new_cont, ktry_get_si(K, body));
+ /* put the source info of the list including the element
+ that we are about to evaluate */
+ kset_source_info(K, new_cont, ktry_get_si(K, body));
#endif
- }
- krooted_tvs_pop(K);
- ktail_eval(K, kcar(body), env);
+ }
+ krooted_tvs_pop(K);
+ ktail_eval(K, kcar(body), env);
}
}
@@ -145,16 +145,16 @@ void wrap(klisp_State *K)
bind_1tp(K, ptree, "combiner", ttiscombiner, comb);
TValue new_app = kwrap(K, comb);
- #if KTRACK_SI
+#if KTRACK_SI
/* save as source code info the info from the expression whose evaluation
got us here */
TValue si = kget_csi(K);
if (!ttisnil(si)) {
- krooted_tvs_push(K, new_app);
- kset_source_info(K, new_app, si);
- krooted_tvs_pop(K);
+ krooted_tvs_push(K, new_app);
+ kset_source_info(K, new_app, si);
+ krooted_tvs_pop(K);
}
- #endif
+#endif
kapply_cc(K, new_app);
}
@@ -194,19 +194,19 @@ void Slambda(klisp_State *K)
krooted_tvs_push(K, vbody);
TValue new_app = kmake_applicative(K, do_vau, 4, vptree, KIGNORE, vbody,
- denv);
- #if KTRACK_SI
+ denv);
+#if KTRACK_SI
/* save as source code info the info from the expression whose evaluation
got us here, both for the applicative and the underlying combiner */
TValue si = kget_csi(K);
if (!ttisnil(si)) {
- krooted_tvs_push(K, new_app);
- kset_source_info(K, new_app, si);
- kset_source_info(K, kunwrap(new_app), si);
- krooted_tvs_pop(K);
+ krooted_tvs_push(K, new_app);
+ kset_source_info(K, new_app, si);
+ kset_source_info(K, kunwrap(new_app), si);
+ krooted_tvs_pop(K);
}
- #endif
+#endif
krooted_tvs_pop(K);
krooted_tvs_pop(K);
@@ -224,12 +224,12 @@ void apply(klisp_State *K)
UNUSED(xparams);
bind_al2tp(K, ptree,
- "applicative", ttisapplicative, app,
- "any", anytype, obj,
- maybe_env);
+ "applicative", ttisapplicative, app,
+ "any", anytype, obj,
+ maybe_env);
TValue env = (get_opt_tpar(K, maybe_env, "environment", ttisenvironment))?
- maybe_env : kmake_empty_environment(K);
+ maybe_env : kmake_empty_environment(K);
krooted_tvs_push(K, env);
TValue expr = kcons(K, kunwrap(app), obj);
@@ -309,32 +309,32 @@ void do_map(klisp_State *K)
/* this case is used to kick start the mapping of both
the acyclic and cyclic part, avoiding code duplication */
if (!dummyp) {
- TValue np = kcons(K, obj, KNIL);
- kset_cdr(last_pair, np);
- last_pair = np;
+ TValue np = kcons(K, obj, KNIL);
+ kset_cdr(last_pair, np);
+ last_pair = np;
}
if (n == 0) {
/* pass the rest of the list and last pair for cycle handling */
- kapply_cc(K, kcons(K, ls, last_pair));
+ kapply_cc(K, kcons(K, ls, last_pair));
} else {
- /* copy the ptree to avoid problems with mutation */
- /* XXX: no check necessary, could just use copy_list if there
- was such a procedure */
- TValue first_ptree = check_copy_list(K, kcar(ls), false, NULL, NULL);
- ls = kcdr(ls);
- n = n-1;
- krooted_tvs_push(K, first_ptree);
- /* have to unwrap the applicative to avoid extra evaluation of first */
- TValue new_expr = kcons(K, kunwrap(app), first_ptree);
- krooted_tvs_push(K, new_expr);
- TValue new_cont =
- kmake_continuation(K, kget_cc(K), do_map, 6, app,
- ls, last_pair, i2tv(n), denv, KFALSE);
- krooted_tvs_pop(K);
- krooted_tvs_pop(K);
- kset_cc(K, new_cont);
- ktail_eval(K, new_expr, denv);
+ /* copy the ptree to avoid problems with mutation */
+ /* XXX: no check necessary, could just use copy_list if there
+ was such a procedure */
+ TValue first_ptree = check_copy_list(K, kcar(ls), false, NULL, NULL);
+ ls = kcdr(ls);
+ n = n-1;
+ krooted_tvs_push(K, first_ptree);
+ /* have to unwrap the applicative to avoid extra evaluation of first */
+ TValue new_expr = kcons(K, kunwrap(app), first_ptree);
+ krooted_tvs_push(K, new_expr);
+ TValue new_cont =
+ kmake_continuation(K, kget_cc(K), do_map, 6, app,
+ ls, last_pair, i2tv(n), denv, KFALSE);
+ krooted_tvs_pop(K);
+ krooted_tvs_pop(K);
+ kset_cc(K, new_cont);
+ ktail_eval(K, new_expr, denv);
}
}
@@ -361,16 +361,16 @@ void do_map_cycle(klisp_State *K)
/* this continuation will close the cycle and return the list */
TValue encycle_cont =
- kmake_continuation(K, kget_cc(K), do_map_encycle, 2,
- dummy, last_apair);
+ kmake_continuation(K, kget_cc(K), do_map_encycle, 2,
+ dummy, last_apair);
krooted_tvs_push(K, encycle_cont);
/* schedule the mapping of the elements of the cycle,
signal dummyp = true to avoid creating a pair for
the inert value passed to the first continuation */
TValue new_cont =
- kmake_continuation(K, encycle_cont, do_map, 6, app, ls,
- last_apair, i2tv(cpairs), denv, KTRUE);
+ kmake_continuation(K, encycle_cont, do_map, 6, app, ls,
+ last_apair, i2tv(cpairs), denv, KTRUE);
klisp_assert(ttisenvironment(denv));
krooted_tvs_pop(K);
@@ -391,8 +391,8 @@ void map(klisp_State *K)
bind_al1tp(K, ptree, "applicative", ttisapplicative, app, lss);
if (ttisnil(lss)) {
- klispE_throw_simple(K, "no lists");
- return;
+ klispE_throw_simple(K, "no lists");
+ return;
}
/* get the metrics of the ptree of each call to app and
@@ -401,13 +401,13 @@ void map(klisp_State *K)
int32_t res_pairs, res_apairs, res_cpairs;
map_for_each_get_metrics(K, lss, &app_apairs, &app_cpairs,
- &res_apairs, &res_cpairs);
+ &res_apairs, &res_cpairs);
app_pairs = app_apairs + app_cpairs;
res_pairs = res_apairs + res_cpairs;
/* create the list of parameters to app */
lss = map_for_each_transpose(K, lss, app_apairs, app_cpairs,
- res_apairs, res_cpairs);
+ res_apairs, res_cpairs);
/* ASK John: the semantics when this is mixed with continuations,
isn't all that great..., but what are the expectations considering
@@ -421,9 +421,9 @@ void map(klisp_State *K)
krooted_tvs_push(K, dummy);
TValue ret_cont = (res_cpairs == 0)?
- kmake_continuation(K, kget_cc(K), do_map_ret, 1, dummy)
- : kmake_continuation(K, kget_cc(K), do_map_cycle, 4,
- app, dummy, i2tv(res_cpairs), denv);
+ kmake_continuation(K, kget_cc(K), do_map_ret, 1, dummy)
+ : kmake_continuation(K, kget_cc(K), do_map_cycle, 4,
+ app, dummy, i2tv(res_cpairs), denv);
krooted_tvs_push(K, ret_cont);
@@ -431,8 +431,8 @@ void map(klisp_State *K)
signal dummyp = true to avoid creating a pair for
the inert value passed to the first continuation */
TValue new_cont =
- kmake_continuation(K, ret_cont, do_map, 6, app, lss, dummy,
- i2tv(res_apairs), denv, KTRUE);
+ kmake_continuation(K, ret_cont, do_map, 6, app, lss, dummy,
+ i2tv(res_apairs), denv, KTRUE);
krooted_tvs_pop(K);
krooted_tvs_pop(K);
@@ -472,7 +472,7 @@ void do_array_map_ret(klisp_State *K)
TValue ls = kcdr(xparams[0]);
TValue (*list_to_array)(klisp_State *K, TValue array, int32_t size) =
- pvalue(xparams[1]);
+ pvalue(xparams[1]);
int32_t length = ivalue(xparams[2]);
/* This will also avoid some problems with continuations
@@ -499,14 +499,14 @@ void array_map(klisp_State *K)
TValue list_to_array_tv = xparams[0];
TValue (*array_to_list)(klisp_State *K, TValue array, int32_t *size) =
- pvalue(xparams[1]);
+ pvalue(xparams[1]);
bind_al1tp(K, ptree, "applicative", ttisapplicative, app, lss);
/* check that lss is a non empty list, and copy it */
if (ttisnil(lss)) {
- klispE_throw_simple(K, "no arguments after applicative");
- return;
+ klispE_throw_simple(K, "no arguments after applicative");
+ return;
}
int32_t app_pairs, app_apairs, app_cpairs;
@@ -526,21 +526,21 @@ void array_map(klisp_State *K)
/* all array will produce acyclic lists */
for(int32_t i = 1 /* jump over first */; i < app_pairs; ++i) {
- head = kcar(tail);
- int32_t pairs;
- ls = array_to_list(K, head, &pairs);
- /* in klisp all arrays should have the same length */
- if (pairs != res_pairs) {
- klispE_throw_simple(K, "arguments of different length");
- return;
- }
- kset_car(tail, ls);
- tail = kcdr(tail);
+ head = kcar(tail);
+ int32_t pairs;
+ ls = array_to_list(K, head, &pairs);
+ /* in klisp all arrays should have the same length */
+ if (pairs != res_pairs) {
+ klispE_throw_simple(K, "arguments of different length");
+ return;
+ }
+ kset_car(tail, ls);
+ tail = kcdr(tail);
}
/* create the list of parameters to app */
lss = map_for_each_transpose(K, lss, app_apairs, app_cpairs,
- res_pairs, 0); /* cycle pairs is always 0 */
+ res_pairs, 0); /* cycle pairs is always 0 */
/* ASK John: the semantics when this is mixed with continuations,
isn't all that great..., but what are the expectations considering
@@ -556,16 +556,16 @@ void array_map(klisp_State *K)
krooted_tvs_push(K, dummy);
TValue ret_cont =
- kmake_continuation(K, kget_cc(K), do_array_map_ret, 3, dummy,
- list_to_array_tv, i2tv(res_pairs));
+ kmake_continuation(K, kget_cc(K), do_array_map_ret, 3, dummy,
+ list_to_array_tv, i2tv(res_pairs));
krooted_tvs_push(K, ret_cont);
/* schedule the mapping of the elements of the acyclic part.
signal dummyp = true to avoid creating a pair for
the inert value passed to the first continuation */
TValue new_cont =
- kmake_continuation(K, ret_cont, do_map, 6, app, lss, dummy,
- i2tv(res_pairs), denv, KTRUE);
+ kmake_continuation(K, ret_cont, do_map, 6, app, lss, dummy,
+ i2tv(res_pairs), denv, KTRUE);
krooted_tvs_pop(K);
krooted_tvs_pop(K);
@@ -588,10 +588,10 @@ void kinit_combiners_ground_env(klisp_State *K)
/* 4.10.1 operative? */
add_applicative(K, ground_env, "operative?", typep, 2, symbol,
- i2tv(K_TOPERATIVE));
+ i2tv(K_TOPERATIVE));
/* 4.10.2 applicative? */
add_applicative(K, ground_env, "applicative?", typep, 2, symbol,
- i2tv(K_TAPPLICATIVE));
+ i2tv(K_TAPPLICATIVE));
/* 4.10.3 $vau */
/* 5.3.1 $vau */
add_operative(K, ground_env, "$vau", Svau, 0);
@@ -607,14 +607,14 @@ void kinit_combiners_ground_env(klisp_State *K)
add_applicative(K, ground_env, "map", map, 0);
/* 5.9.? string-map, vector-map, bytevector-map */
add_applicative(K, ground_env, "string-map", array_map, 2,
- p2tv(list_to_string_h), p2tv(string_to_list_h));
+ p2tv(list_to_string_h), p2tv(string_to_list_h));
add_applicative(K, ground_env, "vector-map", array_map, 2,
- p2tv(list_to_vector_h), p2tv(vector_to_list_h));
+ p2tv(list_to_vector_h), p2tv(vector_to_list_h));
add_applicative(K, ground_env, "bytevector-map", array_map, 2,
- p2tv(list_to_bytevector_h), p2tv(bytevector_to_list_h));
+ p2tv(list_to_bytevector_h), p2tv(bytevector_to_list_h));
/* 6.2.1 combiner? */
add_applicative(K, ground_env, "combiner?", ftypep, 2, symbol,
- p2tv(kcombinerp));
+ p2tv(kcombinerp));
}
/* init continuation names */
diff --git a/src/kgcontinuations.c b/src/kgcontinuations.c
@@ -72,16 +72,16 @@ void extend_continuation(klisp_State *K)
UNUSED(xparams);
bind_al2tp(K, ptree,
- "continuation", ttiscontinuation, cont,
- "applicative", ttisapplicative, app,
- maybe_env);
+ "continuation", ttiscontinuation, cont,
+ "applicative", ttisapplicative, app,
+ maybe_env);
TValue env = (get_opt_tpar(K, maybe_env, "environment", ttisenvironment))?
- maybe_env : kmake_empty_environment(K);
+ maybe_env : kmake_empty_environment(K);
krooted_tvs_push(K, env);
TValue new_cont = kmake_continuation(K, cont,
- do_extended_cont, 2, app, env);
+ do_extended_cont, 2, app, env);
krooted_tvs_pop(K);
kapply_cc(K, new_cont);
}
@@ -96,24 +96,24 @@ void guard_continuation(klisp_State *K)
UNUSED(xparams);
bind_3tp(K, ptree, "any", anytype, entry_guards,
- "continuation", ttiscontinuation, cont,
- "any", anytype, exit_guards);
+ "continuation", ttiscontinuation, cont,
+ "any", anytype, exit_guards);
entry_guards = check_copy_guards(K, "guard-continuation: entry guards",
- entry_guards);
+ entry_guards);
krooted_tvs_push(K, entry_guards);
exit_guards = check_copy_guards(K, "guard-continuation: exit guards",
- exit_guards);
+ exit_guards);
krooted_tvs_push(K, exit_guards);
TValue outer_cont = kmake_continuation(K, cont, do_pass_value,
- 2, entry_guards, denv);
+ 2, entry_guards, denv);
krooted_tvs_push(K, outer_cont);
/* mark it as an outer continuation */
kset_outer_cont(outer_cont);
TValue inner_cont = kmake_continuation(K, outer_cont,
- do_pass_value, 2, exit_guards, denv);
+ do_pass_value, 2, exit_guards, denv);
/* mark it as an outer continuation */
kset_inner_cont(inner_cont);
@@ -137,7 +137,7 @@ void continuation_applicative(klisp_State *K)
UNUSED(denv);
bind_1tp(K, ptree, "continuation",
- ttiscontinuation, cont);
+ ttiscontinuation, cont);
/* cont_app is from kstate, it handles dynamic vars &
interceptions */
TValue app = kmake_applicative(K, cont_app, 1, cont);
@@ -165,7 +165,7 @@ void apply_continuation(klisp_State *K)
UNUSED(denv);
bind_2tp(K, ptree, "continuation", ttiscontinuation,
- cont, "any", anytype, obj);
+ cont, "any", anytype, obj);
/* kcall_cont is from kstate, it handles dynamic vars &
interceptions */
@@ -184,34 +184,34 @@ void Slet_cc(klisp_State *K)
bind_al1tp(K, ptree, "symbol", ttissymbol, sym, objs);
if (ttisnil(objs)) {
- /* we don't even bother creating the environment */
- kapply_cc(K, KINERT);
+ /* we don't even bother creating the environment */
+ kapply_cc(K, KINERT);
} else {
- TValue new_env = kmake_environment(K, denv);
+ TValue new_env = kmake_environment(K, denv);
- /* add binding may allocate, protect env,
- keep in stack until continuation is allocated */
- krooted_tvs_push(K, new_env);
- kadd_binding(K, new_env, sym, kget_cc(K));
+ /* add binding may allocate, protect env,
+ keep in stack until continuation is allocated */
+ krooted_tvs_push(K, new_env);
+ kadd_binding(K, new_env, sym, kget_cc(K));
- /* the list of instructions is copied to avoid mutation */
- /* MAYBE: copy the evaluation structure, ASK John */
- TValue ls = check_copy_list(K, objs, false, NULL, NULL);
+ /* the list of instructions is copied to avoid mutation */
+ /* MAYBE: copy the evaluation structure, ASK John */
+ TValue ls = check_copy_list(K, objs, false, NULL, NULL);
krooted_tvs_push(K, ls);
- /* this is needed because seq continuation doesn't check for
- nil sequence */
- TValue tail = kcdr(ls);
- if (ttispair(tail)) {
- TValue new_cont = kmake_continuation(K, kget_cc(K),
- do_seq, 2, tail, new_env);
- kset_cc(K, new_cont);
- }
+ /* this is needed because seq continuation doesn't check for
+ nil sequence */
+ TValue tail = kcdr(ls);
+ if (ttispair(tail)) {
+ TValue new_cont = kmake_continuation(K, kget_cc(K),
+ do_seq, 2, tail, new_env);
+ kset_cc(K, new_cont);
+ }
- krooted_tvs_pop(K);
+ krooted_tvs_pop(K);
krooted_tvs_pop(K);
- ktail_eval(K, kcar(ls), new_env);
+ ktail_eval(K, kcar(ls), new_env);
}
}
@@ -232,7 +232,7 @@ void kgexit(klisp_State *K)
TValue obj = ptree;
if (!get_opt_tpar(K, obj, "any", anytype))
- obj = KINERT;
+ obj = KINERT;
/* TODO: look out for guards and dynamic variables */
/* should be probably handled in kcall_cont() */
@@ -247,38 +247,38 @@ void kinit_continuations_ground_env(klisp_State *K)
/* 7.1.1 continuation? */
add_applicative(K, ground_env, "continuation?", typep, 2, symbol,
- i2tv(K_TCONTINUATION));
+ i2tv(K_TCONTINUATION));
/* 7.2.2 call/cc */
add_applicative(K, ground_env, "call/cc", call_cc, 0);
/* 7.2.3 extend-continuation */
add_applicative(K, ground_env, "extend-continuation", extend_continuation,
- 0);
+ 0);
/* 7.2.4 guard-continuation */
add_applicative(K, ground_env, "guard-continuation", guard_continuation,
- 0);
+ 0);
/* 7.2.5 continuation->applicative */
add_applicative(K, ground_env, "continuation->applicative",
- continuation_applicative, 0);
+ continuation_applicative, 0);
/* 7.2.6 root-continuation */
klisp_assert(ttiscontinuation(K->root_cont));
add_value(K, ground_env, "root-continuation",
- K->root_cont);
+ K->root_cont);
/* 7.2.7 error-continuation */
klisp_assert(ttiscontinuation(K->error_cont));
add_value(K, ground_env, "error-continuation",
- K->error_cont);
+ K->error_cont);
/* 7.3.1 apply-continuation */
add_applicative(K, ground_env, "apply-continuation", apply_continuation,
- 0);
+ 0);
/* 7.3.2 $let/cc */
add_operative(K, ground_env, "$let/cc", Slet_cc,
- 0);
+ 0);
/* 7.3.3 guard-dynamic-extent */
add_applicative(K, ground_env, "guard-dynamic-extent",
- guard_dynamic_extent, 0);
+ guard_dynamic_extent, 0);
/* 7.3.4 exit */
add_applicative(K, ground_env, "exit", kgexit,
- 0);
+ 0);
}
/* init continuation names */
diff --git a/src/kgcontrol.c b/src/kgcontrol.c
@@ -43,8 +43,8 @@ void Sif(klisp_State *K)
bind_3p(K, ptree, test, cons_c, alt_c);
TValue new_cont =
- kmake_continuation(K, kget_cc(K), do_select_clause,
- 3, denv, cons_c, alt_c);
+ kmake_continuation(K, kget_cc(K), do_select_clause,
+ 3, denv, cons_c, alt_c);
/*
** Mark as a bool checking cont, not necessary but avoids a continuation
** in the last evaluation in the common use of ($if ($or?/$and? ...) ...)
@@ -65,12 +65,12 @@ void do_select_clause(klisp_State *K)
** xparams[2]: alternative clause
*/
if (ttisboolean(obj)) {
- TValue denv = xparams[0];
- TValue clause = bvalue(obj)? xparams[1] : xparams[2];
- ktail_eval(K, clause, denv);
+ TValue denv = xparams[0];
+ TValue clause = bvalue(obj)? xparams[1] : xparams[2];
+ ktail_eval(K, clause, denv);
} else {
- klispE_throw_simple(K, "test is not a boolean");
- return;
+ klispE_throw_simple(K, "test is not a boolean");
+ return;
}
}
@@ -84,29 +84,29 @@ void Ssequence(klisp_State *K)
UNUSED(xparams);
if (ttisnil(ptree)) {
- kapply_cc(K, KINERT);
+ kapply_cc(K, KINERT);
} else {
- /* the list of instructions is copied to avoid mutation */
- /* MAYBE: copy the evaluation structure, ASK John */
- TValue ls = check_copy_list(K, ptree, false, NULL, NULL);
- /* this is needed because seq continuation doesn't check for
- nil sequence */
- /* TODO this could be at least in an inlineable function to
- allow used from $lambda, $vau, $let family, load, etc */
- TValue tail = kcdr(ls);
- if (ttispair(tail)) {
- krooted_tvs_push(K, ls);
- TValue new_cont = kmake_continuation(K, kget_cc(K), do_seq, 2,
- tail, denv);
- kset_cc(K, new_cont);
+ /* the list of instructions is copied to avoid mutation */
+ /* MAYBE: copy the evaluation structure, ASK John */
+ TValue ls = check_copy_list(K, ptree, false, NULL, NULL);
+ /* this is needed because seq continuation doesn't check for
+ nil sequence */
+ /* TODO this could be at least in an inlineable function to
+ allow used from $lambda, $vau, $let family, load, etc */
+ TValue tail = kcdr(ls);
+ if (ttispair(tail)) {
+ krooted_tvs_push(K, ls);
+ TValue new_cont = kmake_continuation(K, kget_cc(K), do_seq, 2,
+ tail, denv);
+ kset_cc(K, new_cont);
#if KTRACK_SI
- /* put the source info of the list including the element
- that we are about to evaluate */
- kset_source_info(K, new_cont, ktry_get_si(K, ls));
+ /* put the source info of the list including the element
+ that we are about to evaluate */
+ kset_source_info(K, new_cont, ktry_get_si(K, ls));
#endif
- krooted_tvs_pop(K);
- }
- ktail_eval(K, kcar(ls), denv);
+ krooted_tvs_pop(K);
+ }
+ ktail_eval(K, kcar(ls), denv);
}
}
@@ -123,7 +123,7 @@ void Ssequence(klisp_State *K)
*/
/* GC: assumes clauses is rooted, uses dummy 1 & 2 */
TValue split_check_cond_clauses(klisp_State *K, TValue clauses,
- TValue *bodies)
+ TValue *bodies)
{
TValue cars = kcons(K, KNIL, KNIL);
krooted_vars_push(K, &cars);
@@ -137,38 +137,38 @@ TValue split_check_cond_clauses(klisp_State *K, TValue clauses,
int32_t count = 0;
while(ttispair(tail) && !kis_marked(tail)) {
- ++count;
- TValue first = kcar(tail);
- if (!ttispair(first)) {
- unmark_list(K, clauses);
- klispE_throw_simple(K, "bad structure in clauses");
- return KNIL;
- }
+ ++count;
+ TValue first = kcar(tail);
+ if (!ttispair(first)) {
+ unmark_list(K, clauses);
+ klispE_throw_simple(K, "bad structure in clauses");
+ return KNIL;
+ }
- TValue new_car = kcons(K, kcar(first), KNIL);
- kset_cdr(last_car_pair, new_car);
- last_car_pair = new_car;
- /* bodies have to be checked later */
- TValue new_cdr = kcons(K, kcdr(first), KNIL);
- kset_cdr(last_cdr_pair, new_cdr);
- last_cdr_pair = new_cdr;
-
- kset_mark(tail, kcons(K, new_car, new_cdr));
- tail = kcdr(tail);
+ TValue new_car = kcons(K, kcar(first), KNIL);
+ kset_cdr(last_car_pair, new_car);
+ last_car_pair = new_car;
+ /* bodies have to be checked later */
+ TValue new_cdr = kcons(K, kcdr(first), KNIL);
+ kset_cdr(last_cdr_pair, new_cdr);
+ last_cdr_pair = new_cdr;
+
+ kset_mark(tail, kcons(K, new_car, new_cdr));
+ tail = kcdr(tail);
}
/* complete the cycles before unmarking */
if (ttispair(tail)) {
- TValue mark = kget_mark(tail);
- kset_cdr(last_car_pair, kcar(mark));
- kset_cdr(last_cdr_pair, kcdr(mark));
+ TValue mark = kget_mark(tail);
+ kset_cdr(last_car_pair, kcar(mark));
+ kset_cdr(last_cdr_pair, kcdr(mark));
}
unmark_list(K, clauses);
if (!ttispair(tail) && !ttisnil(tail)) {
- klispE_throw_simple(K, "expected list (clauses)");
- return KNIL;
+ klispE_throw_simple(K, "expected list (clauses)");
+ return KNIL;
}
/*
@@ -179,10 +179,10 @@ TValue split_check_cond_clauses(klisp_State *K, TValue clauses,
*/
tail = kcdr(cdrs);
while(count--) {
- TValue first = kcar(tail);
- TValue copy = check_copy_list(K, first, false, NULL, NULL);
- kset_car(tail, copy);
- tail = kcdr(tail);
+ TValue first = kcar(tail);
+ TValue copy = check_copy_list(K, first, false, NULL, NULL);
+ kset_car(tail, copy);
+ tail = kcdr(tail);
}
*bodies = kcdr(cdrs);
@@ -209,48 +209,48 @@ void do_cond(klisp_State *K)
TValue denv = xparams[3];
if (!ttisboolean(obj)) {
- klispE_throw_simple(K, "test evaluated to a non boolean value");
- return;
+ klispE_throw_simple(K, "test evaluated to a non boolean value");
+ return;
} else if (bvalue(obj)) {
- if (ttisnil(this_body)) {
- kapply_cc(K, KINERT);
- } else {
- TValue tail = kcdr(this_body);
- if (ttispair(tail)) {
- TValue new_cont = kmake_continuation(K, kget_cc(K), do_seq, 2,
- tail, denv);
- kset_cc(K, new_cont);
+ if (ttisnil(this_body)) {
+ kapply_cc(K, KINERT);
+ } else {
+ TValue tail = kcdr(this_body);
+ if (ttispair(tail)) {
+ TValue new_cont = kmake_continuation(K, kget_cc(K), do_seq, 2,
+ tail, denv);
+ kset_cc(K, new_cont);
#if KTRACK_SI
- /* put the source info of the list including the element
- that we are about to evaluate */
- kset_source_info(K, new_cont, ktry_get_si(K, this_body));
+ /* put the source info of the list including the element
+ that we are about to evaluate */
+ kset_source_info(K, new_cont, ktry_get_si(K, this_body));
#endif
- }
- ktail_eval(K, kcar(this_body), denv);
- }
+ }
+ ktail_eval(K, kcar(this_body), denv);
+ }
} else {
- /* check next clause if there is any*/
- if (ttisnil(tests)) {
- kapply_cc(K, KINERT);
- } else {
- TValue new_cont =
- kmake_continuation(K, kget_cc(K), do_cond, 4,
- kcar(bodies), kcdr(tests), kcdr(bodies),
- denv);
- /*
- ** Mark as a bool checking cont, not necessary but avoids a
- ** continuation in the last evaluation in the common use of
- ** ($cond ... (($or?/$and? ...) ...) ...)
- */
- kset_bool_check_cont(new_cont);
- kset_cc(K, new_cont);
+ /* check next clause if there is any*/
+ if (ttisnil(tests)) {
+ kapply_cc(K, KINERT);
+ } else {
+ TValue new_cont =
+ kmake_continuation(K, kget_cc(K), do_cond, 4,
+ kcar(bodies), kcdr(tests), kcdr(bodies),
+ denv);
+ /*
+ ** Mark as a bool checking cont, not necessary but avoids a
+ ** continuation in the last evaluation in the common use of
+ ** ($cond ... (($or?/$and? ...) ...) ...)
+ */
+ kset_bool_check_cont(new_cont);
+ kset_cc(K, new_cont);
#if KTRACK_SI
- /* put the source info of the list including the element
- that we are about to evaluate */
- kset_source_info(K, new_cont, ktry_get_si(K, tests));
+ /* put the source info of the list including the element
+ that we are about to evaluate */
+ kset_source_info(K, new_cont, ktry_get_si(K, tests));
#endif
- ktail_eval(K, kcar(tests), denv);
- }
+ ktail_eval(K, kcar(tests), denv);
+ }
}
}
@@ -270,18 +270,18 @@ void Scond(klisp_State *K)
TValue obj;
if (ttisnil(tests)) {
- obj = KINERT;
+ obj = KINERT;
} else {
- /* pass a dummy body and a #f to the $cond continuation to
- avoid code repetition here */
- TValue new_cont =
- kmake_continuation(K, kget_cc(K), do_cond, 4,
- KNIL, tests, bodies, denv);
- /* there is no need to mark this continuation with bool check
- because it is just a dummy, no evaluation happens in its
- dynamic extent, no need for source info either */
- kset_cc(K, new_cont);
- obj = KFALSE;
+ /* pass a dummy body and a #f to the $cond continuation to
+ avoid code repetition here */
+ TValue new_cont =
+ kmake_continuation(K, kget_cc(K), do_cond, 4,
+ KNIL, tests, bodies, denv);
+ /* there is no need to mark this continuation with bool check
+ because it is just a dummy, no evaluation happens in its
+ dynamic extent, no need for source info either */
+ kset_cc(K, new_cont);
+ obj = KFALSE;
}
krooted_tvs_pop(K);
@@ -311,24 +311,24 @@ void do_for_each(klisp_State *K)
if (n == 0) {
/* return inert as the final result to for-each */
- kapply_cc(K, KINERT);
+ kapply_cc(K, KINERT);
} else {
- /* copy the ptree to avoid problems with mutation */
- /* XXX: no check necessary, could just use copy_list if there
- was such a procedure */
- TValue first_ptree = check_copy_list(K, kcar(ls), false, NULL, NULL);
- krooted_tvs_push(K, first_ptree);
- ls = kcdr(ls);
- n = n-1;
-
- /* have to unwrap the applicative to avoid extra evaluation of first */
- TValue new_expr = kcons(K, kunwrap(app), first_ptree);
- TValue new_cont =
- kmake_continuation(K, kget_cc(K), do_for_each, 4,
- app, ls, i2tv(n), denv);
- krooted_tvs_pop(K);
- kset_cc(K, new_cont);
- ktail_eval(K, new_expr, denv);
+ /* copy the ptree to avoid problems with mutation */
+ /* XXX: no check necessary, could just use copy_list if there
+ was such a procedure */
+ TValue first_ptree = check_copy_list(K, kcar(ls), false, NULL, NULL);
+ krooted_tvs_push(K, first_ptree);
+ ls = kcdr(ls);
+ n = n-1;
+
+ /* have to unwrap the applicative to avoid extra evaluation of first */
+ TValue new_expr = kcons(K, kunwrap(app), first_ptree);
+ TValue new_cont =
+ kmake_continuation(K, kget_cc(K), do_for_each, 4,
+ app, ls, i2tv(n), denv);
+ krooted_tvs_pop(K);
+ kset_cc(K, new_cont);
+ ktail_eval(K, new_expr, denv);
}
}
@@ -344,8 +344,8 @@ void for_each(klisp_State *K)
bind_al1tp(K, ptree, "applicative", ttisapplicative, app, lss);
if (ttisnil(lss)) {
- klispE_throw_simple(K, "no lists");
- return;
+ klispE_throw_simple(K, "no lists");
+ return;
}
/* get the metrics of the ptree of each call to app and
@@ -354,21 +354,21 @@ void for_each(klisp_State *K)
int32_t res_pairs, res_apairs, res_cpairs;
map_for_each_get_metrics(K, lss, &app_apairs, &app_cpairs,
- &res_apairs, &res_cpairs);
+ &res_apairs, &res_cpairs);
app_pairs = app_apairs + app_cpairs;
res_pairs = res_apairs + res_cpairs;
/* create the list of parameters to app */
lss = map_for_each_transpose(K, lss, app_apairs, app_cpairs,
- res_apairs, res_cpairs);
+ res_apairs, res_cpairs);
krooted_tvs_push(K, lss);
/* schedule all elements at once, the cycle is just ignored, this
will also return #inert once done. */
TValue new_cont =
- kmake_continuation(K, kget_cc(K), do_for_each, 4, app, lss,
- i2tv(res_pairs), denv);
+ kmake_continuation(K, kget_cc(K), do_for_each, 4, app, lss,
+ i2tv(res_pairs), denv);
kset_cc(K, new_cont);
krooted_tvs_pop(K);
/* this will be a nop */
@@ -388,14 +388,14 @@ void array_for_each(klisp_State *K)
*/
TValue (*array_to_list)(klisp_State *K, TValue array, int32_t *size) =
- pvalue(xparams[0]);
+ pvalue(xparams[0]);
bind_al1tp(K, ptree, "applicative", ttisapplicative, app, lss);
/* check that lss is a non empty list, and copy it */
if (ttisnil(lss)) {
- klispE_throw_simple(K, "no arguments after applicative");
- return;
+ klispE_throw_simple(K, "no arguments after applicative");
+ return;
}
int32_t app_pairs, app_apairs, app_cpairs;
@@ -414,21 +414,21 @@ void array_for_each(klisp_State *K)
kset_car(lss, ls); /* save the first */
/* all array will produce acyclic lists */
for(int32_t i = 1 /* jump over first */; i < app_pairs; ++i) {
- head = kcar(tail);
- int32_t pairs;
- ls = array_to_list(K, head, &pairs);
- /* in klisp all arrays should have the same length */
- if (pairs != res_pairs) {
- klispE_throw_simple(K, "arguments of different length");
- return;
- }
- kset_car(tail, ls);
- tail = kcdr(tail);
+ head = kcar(tail);
+ int32_t pairs;
+ ls = array_to_list(K, head, &pairs);
+ /* in klisp all arrays should have the same length */
+ if (pairs != res_pairs) {
+ klispE_throw_simple(K, "arguments of different length");
+ return;
+ }
+ kset_car(tail, ls);
+ tail = kcdr(tail);
}
/* create the list of parameters to app */
lss = map_for_each_transpose(K, lss, app_apairs, app_cpairs,
- res_pairs, 0); /* cycle pairs is always 0 */
+ res_pairs, 0); /* cycle pairs is always 0 */
/* ASK John: the semantics when this is mixed with continuations,
isn't all that great..., but what are the expectations considering
@@ -440,8 +440,8 @@ void array_for_each(klisp_State *K)
/* schedule all elements at once, this will also return #inert once
done. */
TValue new_cont =
- kmake_continuation(K, kget_cc(K), do_for_each, 4, app, lss,
- i2tv(res_pairs), denv);
+ kmake_continuation(K, kget_cc(K), do_for_each, 4, app, lss,
+ i2tv(res_pairs), denv);
kset_cc(K, new_cont);
krooted_tvs_pop(K);
/* this will be a nop */
@@ -469,45 +469,45 @@ void do_Swhen_Sunless(klisp_State *K)
#endif
if (!ttisboolean(obj)) {
- klispE_throw_simple(K, "test is not a boolean");
- return;
+ klispE_throw_simple(K, "test is not a boolean");
+ return;
}
if (bvalue(obj) == cond && !ttisnil(ls)) {
- /* only contruct the #inert returning continuation if the
- current continuation is not of the same type */
- if (!kis_inert_ret_cont(kget_cc(K))) {
- TValue new_cont =
- kmake_continuation(K, kget_cc(K), do_return_value, 1, KINERT);
- /* mark it, so that it can be detected as inert throwing cont */
- kset_inert_ret_cont(new_cont);
- kset_cc(K, new_cont);
+ /* only contruct the #inert returning continuation if the
+ current continuation is not of the same type */
+ if (!kis_inert_ret_cont(kget_cc(K))) {
+ TValue new_cont =
+ kmake_continuation(K, kget_cc(K), do_return_value, 1, KINERT);
+ /* mark it, so that it can be detected as inert throwing cont */
+ kset_inert_ret_cont(new_cont);
+ kset_cc(K, new_cont);
#if KTRACK_SI
- /* put the source info of the whole form */
- kset_source_info(K, new_cont, si);
+ /* put the source info of the whole form */
+ kset_source_info(K, new_cont, si);
#endif
- }
- /* this is needed because seq continuation doesn't check for
- nil sequence */
- /* TODO this could be at least in an inlineable function to
- allow used from $lambda, $vau, $let family, load, etc */
- TValue tail = kcdr(ls);
- if (ttispair(tail)) {
- krooted_tvs_push(K, ls);
- TValue new_cont = kmake_continuation(K, kget_cc(K), do_seq, 2,
- tail, denv);
- kset_cc(K, new_cont);
+ }
+ /* this is needed because seq continuation doesn't check for
+ nil sequence */
+ /* TODO this could be at least in an inlineable function to
+ allow used from $lambda, $vau, $let family, load, etc */
+ TValue tail = kcdr(ls);
+ if (ttispair(tail)) {
+ krooted_tvs_push(K, ls);
+ TValue new_cont = kmake_continuation(K, kget_cc(K), do_seq, 2,
+ tail, denv);
+ kset_cc(K, new_cont);
#if KTRACK_SI
- /* put the source info of the list including the element
- that we are about to evaluate */
- kset_source_info(K, new_cont, ktry_get_si(K, ls));
+ /* put the source info of the list including the element
+ that we are about to evaluate */
+ kset_source_info(K, new_cont, ktry_get_si(K, ls));
#endif
- krooted_tvs_pop(K);
- }
- ktail_eval(K, kcar(ls), denv);
+ krooted_tvs_pop(K);
+ }
+ ktail_eval(K, kcar(ls), denv);
} else {
- /* either the test failed or the body was nil */
- kapply_cc(K, KINERT);
+ /* either the test failed or the body was nil */
+ kapply_cc(K, KINERT);
}
}
@@ -533,9 +533,9 @@ void Swhen_Sunless(klisp_State *K)
/* prepare the continuation that will check the test result
and do the evaluation */
TValue si = K->next_si; /* this is the source info of the whole
- $when/$unless form */
+ $when/$unless form */
TValue new_cont = kmake_continuation(K, kget_cc(K), do_Swhen_Sunless,
- 4, tv_cond, ls, denv, si);
+ 4, tv_cond, ls, denv, si);
krooted_tvs_pop(K);
/*
** Mark as a bool checking cont, not necessary but avoids a continuation
@@ -555,7 +555,7 @@ void kinit_control_ground_env(klisp_State *K)
/* 4.5.1 inert? */
add_applicative(K, ground_env, "inert?", typep, 2, symbol,
- i2tv(K_TINERT));
+ i2tv(K_TINERT));
/* 4.5.2 $if */
add_operative(K, ground_env, "$if", Sif, 0);
/* 5.1.1 $sequence */
@@ -566,16 +566,16 @@ void kinit_control_ground_env(klisp_State *K)
add_applicative(K, ground_env, "for-each", for_each, 0);
/* 6.9.? string-for-each, vector-for-each, bytevector-for-each */
add_applicative(K, ground_env, "string-for-each", array_for_each, 1,
- p2tv(string_to_list_h));
+ p2tv(string_to_list_h));
add_applicative(K, ground_env, "vector-for-each", array_for_each, 1,
- p2tv(vector_to_list_h));
+ p2tv(vector_to_list_h));
add_applicative(K, ground_env, "bytevector-for-each", array_for_each, 1,
- p2tv(bytevector_to_list_h));
+ p2tv(bytevector_to_list_h));
/* ?.? */
add_operative(K, ground_env, "$when", Swhen_Sunless, 1,
- b2tv(true));
+ b2tv(true));
add_operative(K, ground_env, "$unless", Swhen_Sunless, 1,
- b2tv(false));
+ b2tv(false));
}
/* init continuation names */
diff --git a/src/kgencapsulations.c b/src/kgencapsulations.c
@@ -57,9 +57,9 @@ void enc_unwrap(klisp_State *K)
TValue key = xparams[0];
if (!kis_encapsulation_type(enc, key)) {
- klispE_throw_simple(K, "object doesn't belong to this "
- "encapsulation type");
- return;
+ klispE_throw_simple(K, "object doesn't belong to this "
+ "encapsulation type");
+ return;
}
TValue obj = kget_enc_val(enc);
kapply_cc(K, obj);
@@ -103,5 +103,5 @@ void kinit_encapsulations_ground_env(klisp_State *K)
/* 8.1.1 make-encapsulation-type */
add_applicative(K, ground_env, "make-encapsulation-type",
- make_encapsulation_type, 0);
+ make_encapsulation_type, 0);
}
diff --git a/src/kgenv_mut.c b/src/kgenv_mut.c
@@ -45,8 +45,8 @@ void SdefineB(klisp_State *K)
krooted_tvs_push(K, dptree);
TValue new_cont = kmake_continuation(K, kget_cc(K),
- do_match, 3, dptree, denv,
- def_sym);
+ do_match, 3, dptree, denv,
+ def_sym);
kset_cc(K, new_cont);
krooted_tvs_pop(K);
ktail_eval(K, expr, denv);
@@ -87,8 +87,8 @@ void SsetB(klisp_State *K)
krooted_tvs_push(K, formals);
TValue new_cont =
- kmake_continuation(K, kget_cc(K), do_set_eval_obj, 4,
- sname, formals, eval_exp, denv);
+ kmake_continuation(K, kget_cc(K), do_set_eval_obj, 4,
+ sname, formals, eval_exp, denv);
kset_cc(K, new_cont);
krooted_tvs_pop(K);
@@ -113,17 +113,17 @@ void do_set_eval_obj(klisp_State *K)
TValue denv = xparams[3];
if (!ttisenvironment(obj)) {
- klispE_throw_simple(K, "bad type from first "
- "operand evaluation (expected environment)");
- return;
+ klispE_throw_simple(K, "bad type from first "
+ "operand evaluation (expected environment)");
+ return;
} else {
- TValue env = obj;
+ TValue env = obj;
- TValue new_cont =
- kmake_continuation(K, kget_cc(K), do_match, 3,
- formals, env, sname);
- kset_cc(K, new_cont);
- ktail_eval(K, eval_exp, denv);
+ TValue new_cont =
+ kmake_continuation(K, kget_cc(K), do_match, 3,
+ formals, env, sname);
+ kset_cc(K, new_cont);
+ ktail_eval(K, eval_exp, denv);
}
}
@@ -133,11 +133,11 @@ inline void unmark_maybe_symbol_list(klisp_State *K, TValue ls)
{
UNUSED(K);
while(ttispair(ls) && kis_marked(ls)) {
- TValue first = kcar(ls);
- if (ttissymbol(first))
- kunmark_symbol(first);
- kunmark(ls);
- ls = kcdr(ls);
+ TValue first = kcar(ls);
+ if (ttissymbol(first))
+ kunmark_symbol(first);
+ kunmark(ls);
+ ls = kcdr(ls);
}
}
@@ -156,33 +156,33 @@ TValue check_copy_symbol_list(klisp_State *K, TValue obj)
TValue last_pair = slist;
while(ttispair(tail) && !kis_marked(tail)) {
- /* even if there is a type error continue checking the structure */
- TValue first = kcar(tail);
- if (ttissymbol(first)) {
- repeated_errorp |= kis_symbol_marked(first);
- kmark_symbol(first);
- } else {
- type_errorp = true;
- }
- kmark(tail);
-
- TValue new_pair = kcons(K, first, KNIL);
- kset_cdr(last_pair, new_pair);
- last_pair = new_pair;
-
- tail = kcdr(tail);
+ /* even if there is a type error continue checking the structure */
+ TValue first = kcar(tail);
+ if (ttissymbol(first)) {
+ repeated_errorp |= kis_symbol_marked(first);
+ kmark_symbol(first);
+ } else {
+ type_errorp = true;
+ }
+ kmark(tail);
+
+ TValue new_pair = kcons(K, first, KNIL);
+ kset_cdr(last_pair, new_pair);
+ last_pair = new_pair;
+
+ tail = kcdr(tail);
}
unmark_maybe_symbol_list(K, obj);
if (!ttisnil(tail)) {
- klispE_throw_simple(K, "expected finite list");
- return KNIL;
+ klispE_throw_simple(K, "expected finite list");
+ return KNIL;
} else if (type_errorp) {
- klispE_throw_simple(K, "bad operand type (expected list of "
- "symbols)");
- return KNIL;
+ klispE_throw_simple(K, "bad operand type (expected list of "
+ "symbols)");
+ return KNIL;
} else if (repeated_errorp) {
- klispE_throw_simple(K, "repeated symbols");
+ klispE_throw_simple(K, "repeated symbols");
}
krooted_vars_pop(K);
return kcdr(slist);
@@ -203,16 +203,16 @@ void do_import(klisp_State *K)
TValue denv = xparams[2];
if (!ttisenvironment(obj)) {
- klispE_throw_simple(K, "bad type from first "
- "operand evaluation (expected environment)");
- return;
+ klispE_throw_simple(K, "bad type from first "
+ "operand evaluation (expected environment)");
+ return;
} else {
- TValue env = obj;
- TValue new_cont =
- kmake_continuation(K, kget_cc(K), do_match, 3,
- symbols, denv, sname);
- kset_cc(K, new_cont);
- ktail_eval(K, kcons(K, K->list_app, symbols), env);
+ TValue env = obj;
+ TValue new_cont =
+ kmake_continuation(K, kget_cc(K), do_match, 3,
+ symbols, denv, sname);
+ kset_cc(K, new_cont);
+ ktail_eval(K, kcons(K, K->list_app, symbols), env);
}
}
@@ -239,39 +239,39 @@ void SprovideB(klisp_State *K)
/* this will copy the bindings from new_env to denv */
krooted_tvs_push(K, new_env);
TValue import_cont =
- kmake_continuation(K, kget_cc(K), do_import, 3,
- sname, symbols, denv);
+ kmake_continuation(K, kget_cc(K), do_import, 3,
+ sname, symbols, denv);
kset_cc(K, import_cont); /* this implicitly roots import_cont */
/* this will ignore the last value and pass the env to the
above continuation */
TValue ret_exp_cont =
- kmake_continuation(K, import_cont, do_return_value,
- 1, new_env);
+ kmake_continuation(K, import_cont, do_return_value,
+ 1, new_env);
kset_cc(K, ret_exp_cont); /* this implicitly roots ret_exp_cont */
if (ttisnil(body)) {
- krooted_tvs_pop(K);
- krooted_tvs_pop(K);
- krooted_tvs_pop(K);
- kapply_cc(K, KINERT);
+ krooted_tvs_pop(K);
+ krooted_tvs_pop(K);
+ krooted_tvs_pop(K);
+ kapply_cc(K, KINERT);
} else {
- /* this is needed because seq continuation doesn't check for
- nil sequence */
- TValue tail = kcdr(body);
- if (ttispair(tail)) {
- TValue new_cont = kmake_continuation(K, kget_cc(K),
- do_seq, 2, tail, new_env);
- kset_cc(K, new_cont);
+ /* this is needed because seq continuation doesn't check for
+ nil sequence */
+ TValue tail = kcdr(body);
+ if (ttispair(tail)) {
+ TValue new_cont = kmake_continuation(K, kget_cc(K),
+ do_seq, 2, tail, new_env);
+ kset_cc(K, new_cont);
#if KTRACK_SI
- /* put the source info of the list including the element
- that we are about to evaluate */
- kset_source_info(K, new_cont, ktry_get_si(K, body));
+ /* put the source info of the list including the element
+ that we are about to evaluate */
+ kset_source_info(K, new_cont, ktry_get_si(K, body));
#endif
- }
- krooted_tvs_pop(K);
- krooted_tvs_pop(K);
- krooted_tvs_pop(K);
- ktail_eval(K, kcar(body), new_env);
+ }
+ krooted_tvs_pop(K);
+ krooted_tvs_pop(K);
+ krooted_tvs_pop(K);
+ ktail_eval(K, kcar(body), new_env);
}
}
@@ -310,7 +310,7 @@ void SimportB(klisp_State *K)
krooted_tvs_push(K, symbols);
TValue new_cont =
kmake_continuation(K, kget_cc(K), do_import, 3,
- sname, symbols, denv);
+ sname, symbols, denv);
kset_cc(K, new_cont);
krooted_tvs_pop(K);
ktail_eval(K, env_expr, denv);
diff --git a/src/kgenvironments.c b/src/kgenvironments.c
@@ -48,7 +48,7 @@ void eval(klisp_State *K)
UNUSED(xparams);
bind_2tp(K, ptree, "any", anytype, expr,
- "environment", ttisenvironment, env);
+ "environment", ttisenvironment, env);
/* TODO: track source code info */
ktail_eval(K, expr, env);
}
@@ -65,27 +65,27 @@ void make_environment(klisp_State *K)
TValue new_env;
if (ttisnil(ptree)) {
- new_env = kmake_empty_environment(K);
- kapply_cc(K, new_env);
+ new_env = kmake_empty_environment(K);
+ kapply_cc(K, new_env);
} else if (ttispair(ptree) && ttisnil(kcdr(ptree))) {
- /* special common case of one parent, don't keep a list */
- TValue parent = kcar(ptree);
- if (ttisenvironment(parent)) {
- new_env = kmake_environment(K, parent);
- kapply_cc(K, new_env);
- } else {
- klispE_throw_simple(K, "not an environment in "
- "parent list");
- return;
- }
+ /* special common case of one parent, don't keep a list */
+ TValue parent = kcar(ptree);
+ if (ttisenvironment(parent)) {
+ new_env = kmake_environment(K, parent);
+ kapply_cc(K, new_env);
+ } else {
+ klispE_throw_simple(K, "not an environment in "
+ "parent list");
+ return;
+ }
} else {
- /* this is the general case, copy the list but without the
- cycle if there is any */
- TValue parents = check_copy_env_list(K, ptree);
- krooted_tvs_push(K, parents);
- new_env = kmake_environment(K, parents);
- krooted_tvs_pop(K);
- kapply_cc(K, new_env);
+ /* this is the general case, copy the list but without the
+ cycle if there is any */
+ TValue parents = check_copy_env_list(K, ptree);
+ krooted_tvs_push(K, parents);
+ new_env = kmake_environment(K, parents);
+ krooted_tvs_pop(K);
+ kapply_cc(K, new_env);
}
}
@@ -105,7 +105,7 @@ void make_environment(klisp_State *K)
/* GC: assume bindings is rooted */
TValue split_check_let_bindings(klisp_State *K, TValue bindings,
- TValue *exprs, bool starp)
+ TValue *exprs, bool starp)
{
TValue cars = kcons(K, KNIL, KNIL);
krooted_vars_push(K, &cars);
@@ -117,54 +117,54 @@ TValue split_check_let_bindings(klisp_State *K, TValue bindings,
TValue tail = bindings;
while(ttispair(tail) && !kis_marked(tail)) {
- kmark(tail);
- TValue first = kcar(tail);
- if (!ttispair(first) || !ttispair(kcdr(first)) ||
- !ttisnil(kcddr(first))) {
- unmark_list(K, bindings);
- klispE_throw_simple(K, "bad structure in bindings");
- return KNIL;
- }
+ kmark(tail);
+ TValue first = kcar(tail);
+ if (!ttispair(first) || !ttispair(kcdr(first)) ||
+ !ttisnil(kcddr(first))) {
+ unmark_list(K, bindings);
+ klispE_throw_simple(K, "bad structure in bindings");
+ return KNIL;
+ }
- TValue new_car = kcons(K, kcar(first), KNIL);
- kset_cdr(last_car_pair, new_car);
- last_car_pair = new_car;
- TValue new_cadr = kcons(K, kcadr(first), KNIL);
- kset_cdr(last_cadr_pair, new_cadr);
- last_cadr_pair = new_cadr;
-
- tail = kcdr(tail);
+ TValue new_car = kcons(K, kcar(first), KNIL);
+ kset_cdr(last_car_pair, new_car);
+ last_car_pair = new_car;
+ TValue new_cadr = kcons(K, kcadr(first), KNIL);
+ kset_cdr(last_cadr_pair, new_cadr);
+ last_cadr_pair = new_cadr;
+
+ tail = kcdr(tail);
}
unmark_list(K, bindings);
if (!ttispair(tail) && !ttisnil(tail)) {
- klispE_throw_simple(K, "expected list");
- return KNIL;
+ klispE_throw_simple(K, "expected list");
+ return KNIL;
} else if(ttispair(tail)) {
- klispE_throw_simple(K, "expected finite list");
- return KNIL;
+ klispE_throw_simple(K, "expected finite list");
+ return KNIL;
} else {
- TValue res;
- if (starp) {
- /* all bindings are consider individual ptrees in these 'let's,
- replace each ptree with its copy (after checking of course) */
- tail = kcdr(cars);
- while(!ttisnil(tail)) {
- TValue first = kcar(tail);
- TValue copy = check_copy_ptree(K, first, KIGNORE);
- kset_car(tail, copy);
- tail = kcdr(tail);
- }
- res = kcdr(cars);
- } else {
- /* all bindings are consider one ptree in these 'let's */
- res = check_copy_ptree(K, kcdr(cars), KIGNORE);
- }
- *exprs = kcdr(cadrs);
- krooted_vars_pop(K);
- krooted_vars_pop(K);
- return res;
+ TValue res;
+ if (starp) {
+ /* all bindings are consider individual ptrees in these 'let's,
+ replace each ptree with its copy (after checking of course) */
+ tail = kcdr(cars);
+ while(!ttisnil(tail)) {
+ TValue first = kcar(tail);
+ TValue copy = check_copy_ptree(K, first, KIGNORE);
+ kset_car(tail, copy);
+ tail = kcdr(tail);
+ }
+ res = kcdr(cars);
+ } else {
+ /* all bindings are consider one ptree in these 'let's */
+ res = check_copy_ptree(K, kcdr(cars), KIGNORE);
+ }
+ *exprs = kcdr(cadrs);
+ krooted_vars_pop(K);
+ krooted_vars_pop(K);
+ return res;
}
}
@@ -198,34 +198,34 @@ void do_let(klisp_State *K)
match(K, env, ptree, obj);
if (ttisnil(bindings)) {
- if (ttisnil(body)) {
- kapply_cc(K, KINERT);
- } else {
- /* this is needed because seq continuation doesn't check for
- nil sequence */
- TValue tail = kcdr(body);
- if (ttispair(tail)) {
- TValue new_cont = kmake_continuation(K, kget_cc(K),
- do_seq, 2, tail, env);
- kset_cc(K, new_cont);
+ if (ttisnil(body)) {
+ kapply_cc(K, KINERT);
+ } else {
+ /* this is needed because seq continuation doesn't check for
+ nil sequence */
+ TValue tail = kcdr(body);
+ if (ttispair(tail)) {
+ TValue new_cont = kmake_continuation(K, kget_cc(K),
+ do_seq, 2, tail, env);
+ kset_cc(K, new_cont);
#if KTRACK_SI
- /* put the source info of the list including the element
- that we are about to evaluate */
- kset_source_info(K, new_cont, ktry_get_si(K, body));
+ /* put the source info of the list including the element
+ that we are about to evaluate */
+ kset_source_info(K, new_cont, ktry_get_si(K, body));
#endif
- }
- ktail_eval(K, kcar(body), env);
- }
+ }
+ ktail_eval(K, kcar(body), env);
+ }
} else {
- TValue new_env = kmake_environment(K, env);
- krooted_tvs_push(K, new_env);
- TValue new_cont =
- kmake_continuation(K, kget_cc(K), do_let, 7, sname,
- kcar(bindings), kcdr(bindings), kcdr(exprs),
- new_env, b2tv(recp), body);
- krooted_tvs_pop(K);
- kset_cc(K, new_cont);
- ktail_eval(K, kcar(exprs), recp? new_env : env);
+ TValue new_env = kmake_environment(K, env);
+ krooted_tvs_push(K, new_env);
+ TValue new_cont =
+ kmake_continuation(K, kget_cc(K), do_let, 7, sname,
+ kcar(bindings), kcdr(bindings), kcdr(exprs),
+ new_env, b2tv(recp), body);
+ krooted_tvs_pop(K);
+ kset_cc(K, new_cont);
+ ktail_eval(K, kcar(exprs), recp? new_env : env);
}
}
@@ -255,8 +255,8 @@ void Slet(klisp_State *K)
TValue new_env = kmake_environment(K, denv);
krooted_tvs_push(K, new_env);
TValue new_cont =
- kmake_continuation(K, kget_cc(K), do_let, 7, sname,
- bptree, KNIL, KNIL, new_env, b2tv(false), body);
+ kmake_continuation(K, kget_cc(K), do_let, 7, sname,
+ bptree, KNIL, KNIL, new_env, b2tv(false), body);
kset_cc(K, new_cont);
TValue expr = kcons(K, K->list_app, exprs);
@@ -283,20 +283,20 @@ void do_bindsp(klisp_State *K)
int32_t count = ivalue(xparams[1]);
if (!ttisenvironment(obj)) {
- klispE_throw_simple(K, "expected environment as first argument");
- return;
+ klispE_throw_simple(K, "expected environment as first argument");
+ return;
}
TValue env = obj;
TValue res = KTRUE;
while(count--) {
- TValue first = kcar(symbols);
- symbols = kcdr(symbols);
+ TValue first = kcar(symbols);
+ symbols = kcdr(symbols);
- if (!kbinds(K, env, first)) {
- res = KFALSE;
- break;
- }
+ if (!kbinds(K, env, first)) {
+ res = KFALSE;
+ break;
+ }
}
kapply_cc(K, res);
@@ -319,7 +319,7 @@ void Sbindsp(klisp_State *K)
krooted_tvs_push(K, symbols);
TValue new_cont = kmake_continuation(K, kget_cc(K), do_bindsp,
- 2, symbols, i2tv(count));
+ 2, symbols, i2tv(count));
krooted_tvs_pop(K);
kset_cc(K, new_cont);
ktail_eval(K, env_expr, denv);
@@ -379,30 +379,30 @@ void SletS(klisp_State *K)
krooted_tvs_push(K, new_env);
if (ttisnil(bptree)) {
- /* same as $let */
- TValue new_cont =
- kmake_continuation(K, kget_cc(K), do_let, 7, sname,
- bptree, KNIL, KNIL, new_env, b2tv(false), body);
- kset_cc(K, new_cont);
-
- TValue expr = kcons(K, K->list_app, exprs);
- krooted_tvs_pop(K);
- krooted_tvs_pop(K);
- krooted_tvs_pop(K);
- krooted_tvs_pop(K);
- ktail_eval(K, expr, denv);
+ /* same as $let */
+ TValue new_cont =
+ kmake_continuation(K, kget_cc(K), do_let, 7, sname,
+ bptree, KNIL, KNIL, new_env, b2tv(false), body);
+ kset_cc(K, new_cont);
+
+ TValue expr = kcons(K, K->list_app, exprs);
+ krooted_tvs_pop(K);
+ krooted_tvs_pop(K);
+ krooted_tvs_pop(K);
+ krooted_tvs_pop(K);
+ ktail_eval(K, expr, denv);
} else {
- TValue new_cont =
- kmake_continuation(K, kget_cc(K), do_let, 7, sname,
- kcar(bptree), kcdr(bptree), kcdr(exprs),
- new_env, b2tv(false), body);
- kset_cc(K, new_cont);
-
- krooted_tvs_pop(K);
- krooted_tvs_pop(K);
- krooted_tvs_pop(K);
- krooted_tvs_pop(K);
- ktail_eval(K, kcar(exprs), denv);
+ TValue new_cont =
+ kmake_continuation(K, kget_cc(K), do_let, 7, sname,
+ kcar(bptree), kcdr(bptree), kcdr(exprs),
+ new_env, b2tv(false), body);
+ kset_cc(K, new_cont);
+
+ krooted_tvs_pop(K);
+ krooted_tvs_pop(K);
+ krooted_tvs_pop(K);
+ krooted_tvs_pop(K);
+ ktail_eval(K, kcar(exprs), denv);
}
}
@@ -432,8 +432,8 @@ void Sletrec(klisp_State *K)
krooted_tvs_push(K, new_env);
TValue new_cont =
- kmake_continuation(K, kget_cc(K), do_let, 7, sname,
- bptree, KNIL, KNIL, new_env, b2tv(true), body);
+ kmake_continuation(K, kget_cc(K), do_let, 7, sname,
+ bptree, KNIL, KNIL, new_env, b2tv(true), body);
kset_cc(K, new_cont);
TValue expr = kcons(K, K->list_app, exprs);
@@ -471,31 +471,31 @@ void SletrecS(klisp_State *K)
krooted_tvs_push(K, new_env);
if (ttisnil(bptree)) {
- /* same as $letrec */
- TValue new_cont =
- kmake_continuation(K, kget_cc(K), do_let, 7, sname,
- bptree, KNIL, KNIL, new_env, b2tv(true), body);
- kset_cc(K, new_cont);
-
- TValue expr = kcons(K, K->list_app, exprs);
-
- krooted_tvs_pop(K);
- krooted_tvs_pop(K);
- krooted_tvs_pop(K);
- krooted_tvs_pop(K);
- ktail_eval(K, expr, new_env);
+ /* same as $letrec */
+ TValue new_cont =
+ kmake_continuation(K, kget_cc(K), do_let, 7, sname,
+ bptree, KNIL, KNIL, new_env, b2tv(true), body);
+ kset_cc(K, new_cont);
+
+ TValue expr = kcons(K, K->list_app, exprs);
+
+ krooted_tvs_pop(K);
+ krooted_tvs_pop(K);
+ krooted_tvs_pop(K);
+ krooted_tvs_pop(K);
+ ktail_eval(K, expr, new_env);
} else {
- TValue new_cont =
- kmake_continuation(K, kget_cc(K), do_let, 7, sname,
- kcar(bptree), kcdr(bptree), kcdr(exprs),
- new_env, b2tv(true), body);
- kset_cc(K, new_cont);
-
- krooted_tvs_pop(K);
- krooted_tvs_pop(K);
- krooted_tvs_pop(K);
- krooted_tvs_pop(K);
- ktail_eval(K, kcar(exprs), new_env);
+ TValue new_cont =
+ kmake_continuation(K, kget_cc(K), do_let, 7, sname,
+ kcar(bptree), kcdr(bptree), kcdr(exprs),
+ new_env, b2tv(true), body);
+ kset_cc(K, new_cont);
+
+ krooted_tvs_pop(K);
+ krooted_tvs_pop(K);
+ krooted_tvs_pop(K);
+ krooted_tvs_pop(K);
+ ktail_eval(K, kcar(exprs), new_env);
}
}
@@ -519,14 +519,14 @@ void do_let_redirect(klisp_State *K)
TValue body = xparams[4];
if (!ttisenvironment(obj)) {
- klispE_throw_simple(K, "expected environment");
- return;
+ klispE_throw_simple(K, "expected environment");
+ return;
}
TValue new_env = kmake_environment(K, obj);
krooted_tvs_push(K, new_env);
TValue new_cont =
- kmake_continuation(K, kget_cc(K), do_let, 7, sname,
- bptree, KNIL, KNIL, new_env, b2tv(false), body);
+ kmake_continuation(K, kget_cc(K), do_let, 7, sname,
+ bptree, KNIL, KNIL, new_env, b2tv(false), body);
kset_cc(K, new_cont);
krooted_tvs_pop(K);
@@ -559,8 +559,8 @@ void Slet_redirect(klisp_State *K)
krooted_tvs_push(K, eexpr);
TValue new_cont =
- kmake_continuation(K, kget_cc(K), do_let_redirect, 5, sname,
- bptree, eexpr, denv, body);
+ kmake_continuation(K, kget_cc(K), do_let_redirect, 5, sname,
+ bptree, eexpr, denv, body);
kset_cc(K, new_cont);
krooted_tvs_pop(K);
@@ -600,8 +600,8 @@ void Slet_safe(klisp_State *K)
TValue new_env = kmake_environment(K, K->ground_env);
krooted_tvs_push(K, new_env);
TValue new_cont =
- kmake_continuation(K, kget_cc(K), do_let, 7, sname,
- bptree, KNIL, KNIL, new_env, b2tv(false), body);
+ kmake_continuation(K, kget_cc(K), do_let, 7, sname,
+ bptree, KNIL, KNIL, new_env, b2tv(false), body);
kset_cc(K, new_cont);
TValue expr = kcons(K, K->list_app, exprs);
@@ -626,7 +626,7 @@ void Sremote_eval(klisp_State *K)
bind_2p(K, ptree, obj, env_exp);
TValue new_cont = kmake_continuation(K, kget_cc(K),
- do_remote_eval, 1, obj);
+ do_remote_eval, 1, obj);
kset_cc(K, new_cont);
ktail_eval(K, env_exp, denv);
@@ -639,12 +639,12 @@ void do_remote_eval(klisp_State *K)
TValue obj = K->next_value;
klisp_assert(ttisnil(K->next_env));
if (!ttisenvironment(obj)) {
- klispE_throw_simple(K, "bad type from second operand "
- "evaluation (expected environment)");
- return;
+ klispE_throw_simple(K, "bad type from second operand "
+ "evaluation (expected environment)");
+ return;
} else {
- TValue eval_exp = xparams[0];
- ktail_eval(K, eval_exp, obj);
+ TValue eval_exp = xparams[0];
+ ktail_eval(K, eval_exp, obj);
}
}
@@ -682,7 +682,7 @@ void Sbindings_to_environment(klisp_State *K)
krooted_tvs_push(K, new_env);
TValue new_cont = kmake_continuation(K, kget_cc(K),
- do_b_to_env, 2, bptree, new_env);
+ do_b_to_env, 2, bptree, new_env);
kset_cc(K, new_cont);
TValue expr = kcons(K, K->list_app, exprs);
@@ -716,7 +716,7 @@ void eval_string(klisp_State *K)
UNUSED(denv);
bind_2tp(K, ptree, "string", ttisstring, str,
- "environment", ttisenvironment, env);
+ "environment", ttisenvironment, env);
/* create a continuation for better stack traces
in case of error */
@@ -728,17 +728,17 @@ void eval_string(klisp_State *K)
TValue obj = kread_from_port(K, port, true); /* read mutable pairs */
if (ttiseof(obj)) {
- klispE_throw_simple_with_irritants(K, "No object found in string", 1,
- str);
- return;
+ klispE_throw_simple_with_irritants(K, "No object found in string", 1,
+ str);
+ return;
}
krooted_tvs_push(K, obj);
TValue second_obj = kread_from_port(K, port, true);
krooted_tvs_pop(K);
if (!ttiseof(second_obj)) {
- klispE_throw_simple_with_irritants(K, "More than one object found "
- "in string", 1, str);
- return;
+ klispE_throw_simple_with_irritants(K, "More than one object found "
+ "in string", 1, str);
+ return;
}
kapply_cc(K, obj);
}
@@ -751,10 +751,10 @@ void kinit_environments_ground_env(klisp_State *K)
/* 4.8.1 environment? */
add_applicative(K, ground_env, "environment?", typep, 2, symbol,
- i2tv(K_TENVIRONMENT));
+ i2tv(K_TENVIRONMENT));
/* 4.8.2 ignore? */
add_applicative(K, ground_env, "ignore?", typep, 2, symbol,
- i2tv(K_TIGNORE));
+ i2tv(K_TIGNORE));
/* 4.8.3 eval */
add_applicative(K, ground_env, "eval", eval, 0);
/* 4.8.4 make-environment */
@@ -765,10 +765,10 @@ void kinit_environments_ground_env(klisp_State *K)
add_operative(K, ground_env, "$binds?", Sbindsp, 0);
/* 6.7.2 get-current-environment */
add_applicative(K, ground_env, "get-current-environment",
- get_current_environment, 0);
+ get_current_environment, 0);
/* 6.7.3 make-kernel-standard-environment */
add_applicative(K, ground_env, "make-kernel-standard-environment",
- make_kernel_standard_environment, 0);
+ make_kernel_standard_environment, 0);
/* 6.7.4 $let* */
add_operative(K, ground_env, "$let*", SletS, 1, symbol);
/* 6.7.5 $letrec */
@@ -783,7 +783,7 @@ void kinit_environments_ground_env(klisp_State *K)
add_operative(K, ground_env, "$remote-eval", Sremote_eval, 0);
/* 6.7.10 $bindings->environment */
add_operative(K, ground_env, "$bindings->environment",
- Sbindings_to_environment, 1, symbol);
+ Sbindings_to_environment, 1, symbol);
/* ?.? eval-string */
add_applicative(K, ground_env, "eval-string", eval_string, 0);
}
diff --git a/src/kgeqp.c b/src/kgeqp.c
@@ -41,14 +41,14 @@ void eqp(klisp_State *K)
TValue tail = ptree;
TValue res = KTRUE;
while(comps-- > 0) { /* comps could be -1 if ptree is nil */
- TValue first = kcar(tail);
- tail = kcdr(tail); /* tail only advances one place per iteration */
- TValue second = kcar(tail);
+ TValue first = kcar(tail);
+ tail = kcdr(tail); /* tail only advances one place per iteration */
+ TValue second = kcar(tail);
- if (!eq2p(K, first, second)) {
- res = KFALSE;
- break;
- }
+ if (!eq2p(K, first, second)) {
+ res = KFALSE;
+ break;
+ }
}
kapply_cc(K, res);
diff --git a/src/kgequalp.c b/src/kgequalp.c
@@ -53,14 +53,14 @@ void equalp(klisp_State *K)
TValue tail = ptree;
TValue res = KTRUE;
while(comps-- > 0) { /* comps could be -1 if ptree is nil */
- TValue first = kcar(tail);
- tail = kcdr(tail); /* tail only advances one place per iteration */
- TValue second = kcar(tail);
+ TValue first = kcar(tail);
+ tail = kcdr(tail); /* tail only advances one place per iteration */
+ TValue second = kcar(tail);
- if (!equal2p(K, first, second)) {
- res = KFALSE;
- break;
- }
+ if (!equal2p(K, first, second)) {
+ res = KFALSE;
+ break;
+ }
}
kapply_cc(K, res);
diff --git a/src/kgerrors.c b/src/kgerrors.c
@@ -94,7 +94,7 @@ void kinit_error_hierarchy(klisp_State *K)
klisp_assert(ttisinert(K->system_error_cont));
K->system_error_cont = kmake_continuation(K, K->error_cont,
- do_exception_cont, 0);
+ do_exception_cont, 0);
}
/* init ground */
@@ -104,14 +104,14 @@ void kinit_error_ground_env(klisp_State *K)
TValue symbol, value;
add_applicative(K, ground_env, "error-object?", typep, 2, symbol,
- i2tv(K_TERROR));
+ i2tv(K_TERROR));
add_applicative(K, ground_env, "error", kgerror, 0);
add_applicative(K, ground_env, "raise", kgraise, 0);
/* MAYBE add get- and remove object from these names */
add_applicative(K, ground_env, "error-object-message",
- error_object_message, 0);
+ error_object_message, 0);
add_applicative(K, ground_env, "error-object-irritants",
- error_object_irritants, 0);
+ error_object_irritants, 0);
/* TODO raise-continuable from r7rs doesn't make sense in the Kernel
system of handling continuations.
What we could have is a more sofisticated system
diff --git a/src/kgffi.c b/src/kgffi.c
@@ -72,7 +72,7 @@ typedef struct {
size_t index;
} ffi_callback_t;
-#define CB_INDEX_N 0
+#define CB_INDEX_N 0
#define CB_INDEX_STACK 1
#define CB_INDEX_FIRST_CALLBACK 2
@@ -131,7 +131,7 @@ static void ffi_encode_pointer(ffi_codec_t *self, klisp_State *K, TValue v, void
} else if (ttisnil(v)) {
*(void **)buf = NULL;
} else if (tbasetype_(v) == K_TAG_USER) {
- /* TODO: do not use internal macro tbasetype_ */
+ /* TODO: do not use internal macro tbasetype_ */
*(void **)buf = pvalue(v);
} else {
klispE_throw_simple_with_irritants(K, "neither bytevector, string, pointer or nil", 1, v);
@@ -236,8 +236,8 @@ static TValue ffi_decode_uint32(ffi_codec_t *self, klisp_State *K, const void *b
uint8_t d[4];
for (int i = 3; i >= 0; i--) {
- d[i] = (x & 0xFF);
- x >>= 8;
+ d[i] = (x & 0xFF);
+ x >>= 8;
}
mp_int_read_unsigned(K, tv2bigint(res), d, 4);
@@ -292,14 +292,14 @@ static void ffi_encode_uint64(ffi_codec_t *self, klisp_State *K, TValue v, void
if (ttisfixint(v) && 0 <= ivalue(v)) {
*(uint64_t *) buf = ivalue(v);
} else if (ttisbigint(v)
- && mp_int_compare_zero(tv2bigint(v)) >= 0
- && mp_int_unsigned_len(tv2bigint(v)) <= 8) {
+ && mp_int_compare_zero(tv2bigint(v)) >= 0
+ && mp_int_unsigned_len(tv2bigint(v)) <= 8) {
uint8_t d[8];
mp_int_to_unsigned(K, tv2bigint(v), d, 8);
uint64_t tmp = d[0];
for (int i = 1; i < 8; i++)
- tmp = (tmp << 8) | d[i];
+ tmp = (tmp << 8) | d[i];
*(uint64_t *) buf = tmp;
} else {
klispE_throw_simple_with_irritants(K, "unable to convert to C uint64_t", 1, v);
@@ -391,8 +391,8 @@ void ffi_load_library(klisp_State *K)
TValue filename = ptree;
const char *filename_c =
- get_opt_tpar(K, filename, "string", ttisstring)
- ? kstring_buf(filename) : NULL;
+ get_opt_tpar(K, filename, "string", ttisstring)
+ ? kstring_buf(filename) : NULL;
#if KGFFI_DLFCN
void *handle = dlopen(filename_c, RTLD_LAZY | RTLD_GLOBAL);
@@ -408,11 +408,11 @@ void ffi_load_library(klisp_State *K)
/* TODO: unicode and wide character issues ??? */
HMODULE handle = LoadLibrary(filename_c);
if (handle == NULL) {
- krooted_tvs_push(K, filename);
- TValue err = ffi_win32_error_message(K, GetLastError());
- klispE_throw_simple_with_irritants(K, "couldn't load dynamic library",
- 2, filename, err);
- return;
+ krooted_tvs_push(K, filename);
+ TValue err = ffi_win32_error_message(K, GetLastError());
+ klispE_throw_simple_with_irritants(K, "couldn't load dynamic library",
+ 2, filename, err);
+ return;
}
#else
# error
@@ -451,12 +451,12 @@ static ffi_abi tv2ffi_abi(klisp_State *K, TValue v)
static ffi_codec_t *tv2ffi_codec(klisp_State *K, TValue v)
{
- for (size_t i = 0; i < sizeof(ffi_codecs)/sizeof(ffi_codecs[0]); i++) {
- if (!strcmp(ffi_codecs[i].name, kstring_buf(v)))
- return &ffi_codecs[i];
- }
- klispE_throw_simple_with_irritants(K, "unsupported FFI type", 1, v);
- return NULL;
+ for (size_t i = 0; i < sizeof(ffi_codecs)/sizeof(ffi_codecs[0]); i++) {
+ if (!strcmp(ffi_codecs[i].name, kstring_buf(v)))
+ return &ffi_codecs[i];
+ }
+ klispE_throw_simple_with_irritants(K, "unsupported FFI type", 1, v);
+ return NULL;
}
inline size_t align(size_t offset, size_t alignment)
@@ -478,20 +478,20 @@ void ffi_make_call_interface(klisp_State *K)
#define ttislist(v) (ttispair(v) || ttisnil(v))
bind_3tp(K, ptree,
- "abi string", ttisstring, abi_tv,
- "rtype string", ttisstring, rtype_tv,
- "argtypes string list", ttislist, argtypes_tv);
+ "abi string", ttisstring, abi_tv,
+ "rtype string", ttisstring, rtype_tv,
+ "argtypes string list", ttislist, argtypes_tv);
#undef ttislist
size_t nargs;
check_typed_list(K, kstringp, false, argtypes_tv, (int32_t *) &nargs,
- NULL);
+ NULL);
/* Allocate C structure ffi_call_interface_t inside
- a mutable bytevector. The structure contains C pointers
- into itself. It must never be reallocated or copied.
- The bytevector will be encapsulated later to protect
- it from lisp code. */
+ a mutable bytevector. The structure contains C pointers
+ into itself. It must never be reallocated or copied.
+ The bytevector will be encapsulated later to protect
+ it from lisp code. */
size_t bytevector_size = sizeof(ffi_call_interface_t) + (sizeof(ffi_codec_t *) + sizeof(ffi_type)) * nargs;
TValue bytevector = kbytevector_new_sf(K, bytevector_size, 0);
@@ -524,17 +524,17 @@ void ffi_make_call_interface(klisp_State *K)
ffi_status status = ffi_prep_cif(&p->cif, abi, nargs, p->rcodec->libffi_type, p->argtypes);
switch (status) {
- case FFI_OK:
- break;
- case FFI_BAD_ABI:
- klispE_throw_simple(K, "FFI_BAD_ABI");
- return;
- case FFI_BAD_TYPEDEF:
- klispE_throw_simple(K, "FFI_BAD_TYPEDEF");
- return;
- default:
- klispE_throw_simple(K, "unknown error in ffi_prep_cif");
- return;
+ case FFI_OK:
+ break;
+ case FFI_BAD_ABI:
+ klispE_throw_simple(K, "FFI_BAD_ABI");
+ return;
+ case FFI_BAD_TYPEDEF:
+ klispE_throw_simple(K, "FFI_BAD_TYPEDEF");
+ return;
+ default:
+ klispE_throw_simple(K, "unknown error in ffi_prep_cif");
+ return;
}
TValue key = xparams[0];
@@ -604,9 +604,9 @@ void ffi_make_applicative(klisp_State *K)
*/
bind_3tp(K, ptree,
- "dynamic library", ttisencapsulation, lib_tv,
- "function name string", ttisstring, name_tv,
- "call interface", ttisencapsulation, cif_tv);
+ "dynamic library", ttisencapsulation, lib_tv,
+ "function name string", ttisstring, name_tv,
+ "call interface", ttisencapsulation, cif_tv);
if (!kis_encapsulation_type(lib_tv, xparams[0])) {
klispE_throw_simple(K, "first argument shall be dynamic library");
return;
@@ -640,10 +640,10 @@ void ffi_make_applicative(klisp_State *K)
HMODULE handle = pvalue(kcar(kget_enc_val(lib_tv)));
void *funptr = GetProcAddress(handle, kstring_buf(name_tv));
if (NULL == funptr) {
- TValue err = ffi_win32_error_message(K, GetLastError());
- klispE_throw_simple_with_irritants(K, "couldn't find symbol",
- 3, lib_name, name_tv, err);
- return;
+ TValue err = ffi_win32_error_message(K, GetLastError());
+ klispE_throw_simple_with_irritants(K, "couldn't find symbol",
+ 3, lib_name, name_tv, err);
+ return;
}
#else
# error
@@ -914,8 +914,8 @@ void ffi_make_callback(klisp_State *K)
*/
bind_2tp(K, ptree,
- "applicative", ttisapplicative, app_tv,
- "call interface", ttisencapsulation, cif_tv);
+ "applicative", ttisapplicative, app_tv,
+ "call interface", ttisencapsulation, cif_tv);
if (!kis_encapsulation_type(cif_tv, xparams[0])) {
klispE_throw_simple(K, "second argument shall be call interface");
return;
@@ -1032,12 +1032,12 @@ void ffi_memmove(klisp_State *K)
UNUSED(denv);
bind_3tp(K, ptree,
- "any", anytype, dst_tv,
- "any", anytype, src_tv,
- "integer", ttisfixint, sz_tv);
+ "any", anytype, dst_tv,
+ "any", anytype, src_tv,
+ "integer", ttisfixint, sz_tv);
if (ivalue(sz_tv) < 0)
- klispE_throw_simple(K, "size should be nonnegative fixint");
+ klispE_throw_simple(K, "size should be nonnegative fixint");
size_t sz = (size_t) ivalue(sz_tv);
uint8_t * dst = ffi_memory_location(K, true, dst_tv, true, sz);
@@ -1064,7 +1064,7 @@ static void ffi_type_ref(klisp_State *K)
const uint8_t *ptr = ffi_memory_location(K, true, location_tv, false, codec->libffi_type->size);
#if KGFFI_CHECK_ALIGNMENT
if ((size_t) ptr % codec->libffi_type->alignment != 0)
- klispE_throw_simple(K, "unaligned memory read through FFI");
+ klispE_throw_simple(K, "unaligned memory read through FFI");
#endif
TValue result = codec->decode(codec, K, ptr);
@@ -1090,7 +1090,7 @@ static void ffi_type_set(klisp_State *K)
uint8_t *ptr = ffi_memory_location(K, true, location_tv, false, codec->libffi_type->size);
#if KGFFI_CHECK_ALIGNMENT
if ((size_t) ptr % codec->libffi_type->alignment != 0)
- klispE_throw_simple(K, "unaligned memory write through FFI");
+ klispE_throw_simple(K, "unaligned memory write through FFI");
#endif
codec->encode(codec, K, value_tv, ptr);
@@ -1189,7 +1189,7 @@ void kinit_ffi_cont_names(klisp_State *K)
Table *t = tv2table(K->cont_name_table);
add_cont_name(K, t, do_ffi_callback_encode_result,
- "ffi-callback-encode-result");
+ "ffi-callback-encode-result");
add_cont_name(K, t, do_ffi_callback_return,
- "ffi-callback-ret");
+ "ffi-callback-ret");
}
diff --git a/src/kghelpers.c b/src/kghelpers.c
@@ -94,18 +94,18 @@ void enc_typep(klisp_State *K)
TValue tail = ptree;
while(ttispair(tail) && kis_unmarked(tail)) {
- kmark(tail);
- res &= kis_encapsulation_type(kcar(tail), key);
- tail = kcdr(tail);
+ kmark(tail);
+ res &= kis_encapsulation_type(kcar(tail), key);
+ tail = kcdr(tail);
}
unmark_list(K, ptree);
if (ttispair(tail) || ttisnil(tail)) {
- kapply_cc(K, b2tv(res));
+ kapply_cc(K, b2tv(res));
} else {
- /* try to get name from encapsulation */
- klispE_throw_simple(K, "expected list");
- return;
+ /* try to get name from encapsulation */
+ klispE_throw_simple(K, "expected list");
+ return;
}
}
/* /Type predicates */
@@ -117,18 +117,18 @@ bool kpositivep(TValue n)
case K_TFIXINT:
case K_TEINF:
case K_TIINF:
- return ivalue(n) > 0;
+ return ivalue(n) > 0;
case K_TBIGINT:
- return kbigint_positivep(n);
+ return kbigint_positivep(n);
case K_TBIGRAT:
- return kbigrat_positivep(n);
+ return kbigrat_positivep(n);
case K_TDOUBLE:
- return dvalue(n) > 0.0;
- /* real with no prim value, complex and undefined should be captured by
- type predicate */
+ return dvalue(n) > 0.0;
+ /* real with no prim value, complex and undefined should be captured by
+ type predicate */
default:
- klisp_assert(0);
- return false;
+ klisp_assert(0);
+ return false;
}
}
@@ -138,18 +138,18 @@ bool knegativep(TValue n)
case K_TFIXINT:
case K_TEINF:
case K_TIINF:
- return ivalue(n) < 0;
+ return ivalue(n) < 0;
case K_TBIGINT:
- return kbigint_negativep(n);
+ return kbigint_negativep(n);
case K_TBIGRAT:
- return kbigrat_negativep(n);
+ return kbigrat_negativep(n);
case K_TDOUBLE:
- return dvalue(n) < 0.0;
- /* real with no prim value, complex and undefined should be captured by
- type predicate */
+ return dvalue(n) < 0.0;
+ /* real with no prim value, complex and undefined should be captured by
+ type predicate */
default:
- klisp_assert(0);
- return false;
+ klisp_assert(0);
+ return false;
}
}
/* /some number functions */
@@ -174,17 +174,17 @@ void typep(klisp_State *K)
TValue tail = ptree;
while(ttispair(tail) && kis_unmarked(tail)) {
- kmark(tail);
- res &= ttype(kcar(tail)) == tag;
- tail = kcdr(tail);
+ kmark(tail);
+ res &= ttype(kcar(tail)) == tag;
+ tail = kcdr(tail);
}
unmark_list(K, ptree);
if (ttispair(tail) || ttisnil(tail)) {
- kapply_cc(K, b2tv(res));
+ kapply_cc(K, b2tv(res));
} else {
- klispE_throw_simple(K, "expected list");
- return;
+ klispE_throw_simple(K, "expected list");
+ return;
}
}
@@ -208,17 +208,17 @@ void ftypep(klisp_State *K)
TValue tail = ptree;
while(ttispair(tail) && kis_unmarked(tail)) {
- kmark(tail);
- res &= (*fn)(kcar(tail));
- tail = kcdr(tail);
+ kmark(tail);
+ res &= (*fn)(kcar(tail));
+ tail = kcdr(tail);
}
unmark_list(K, ptree);
if (ttispair(tail) || ttisnil(tail)) {
- kapply_cc(K, b2tv(res));
+ kapply_cc(K, b2tv(res));
} else {
- klispE_throw_simple(K, "expected list");
- return;
+ klispE_throw_simple(K, "expected list");
+ return;
}
}
@@ -252,15 +252,15 @@ void ftyped_predp(klisp_State *K)
Keep going even if the result is false to catch errors in
type */
while(pairs--) {
- TValue first = kcar(tail);
-
- if (!(*typep)(first)) {
- /* TODO show expected type */
- klispE_throw_simple(K, "bad argument type");
- return;
- }
- res &= (*predp)(first);
- tail = kcdr(tail);
+ TValue first = kcar(tail);
+
+ if (!(*typep)(first)) {
+ /* TODO show expected type */
+ klispE_throw_simple(K, "bad argument type");
+ return;
+ }
+ res &= (*predp)(first);
+ tail = kcdr(tail);
}
kapply_cc(K, b2tv(res));
}
@@ -300,27 +300,27 @@ void ftyped_bpredp(klisp_State *K)
type */
if (comps == 0) {
- /* this case has to be here because otherwise there is no check
- for the type of the lone operand */
- TValue first = kcar(tail);
- if (!(*typep)(first)) {
- /* TODO show expected type */
- klispE_throw_simple(K, "bad argument type");
- return;
- }
+ /* this case has to be here because otherwise there is no check
+ for the type of the lone operand */
+ TValue first = kcar(tail);
+ if (!(*typep)(first)) {
+ /* TODO show expected type */
+ klispE_throw_simple(K, "bad argument type");
+ return;
+ }
}
while(comps-- > 0) { /* comps could be -1 if ptree is () */
- TValue first = kcar(tail);
- tail = kcdr(tail); /* tail only advances one place per iteration */
- TValue second = kcar(tail);
-
- if (!(*typep)(first) || !(*typep)(second)) {
- /* TODO show expected type */
- klispE_throw_simple(K, "bad argument type");
- return;
- }
- res &= (*predp)(first, second);
+ TValue first = kcar(tail);
+ tail = kcdr(tail); /* tail only advances one place per iteration */
+ TValue second = kcar(tail);
+
+ if (!(*typep)(first) || !(*typep)(second)) {
+ /* TODO show expected type */
+ klispE_throw_simple(K, "bad argument type");
+ return;
+ }
+ res &= (*predp)(first, second);
}
kapply_cc(K, b2tv(res));
}
@@ -341,7 +341,7 @@ void ftyped_kbpredp(klisp_State *K)
*/
bool (*typep)(TValue obj) = pvalue(xparams[1]);
bool (*predp)(klisp_State *K, TValue obj1, TValue obj2) =
- pvalue(xparams[2]);
+ pvalue(xparams[2]);
/* check the ptree is a list first to allow the structure
errors to take precedence over the type errors. */
@@ -360,153 +360,153 @@ void ftyped_kbpredp(klisp_State *K)
type */
if (comps == 0) {
- /* this case has to be here because otherwise there is no check
- for the type of the lone operand */
- TValue first = kcar(tail);
- if (!(*typep)(first)) {
- /* TODO show expected type */
- klispE_throw_simple(K, "bad argument type");
- return;
- }
+ /* this case has to be here because otherwise there is no check
+ for the type of the lone operand */
+ TValue first = kcar(tail);
+ if (!(*typep)(first)) {
+ /* TODO show expected type */
+ klispE_throw_simple(K, "bad argument type");
+ return;
+ }
}
while(comps-- > 0) { /* comps could be -1 if ptree is () */
- TValue first = kcar(tail);
- tail = kcdr(tail); /* tail only advances one place per iteration */
- TValue second = kcar(tail);
-
- if (!(*typep)(first) || !(*typep)(second)) {
- /* TODO show expected type */
- klispE_throw_simple(K, "bad argument type");
- return;
- }
- res &= (*predp)(K, first, second);
+ TValue first = kcar(tail);
+ tail = kcdr(tail); /* tail only advances one place per iteration */
+ TValue second = kcar(tail);
+
+ if (!(*typep)(first) || !(*typep)(second)) {
+ /* TODO show expected type */
+ klispE_throw_simple(K, "bad argument type");
+ return;
+ }
+ res &= (*predp)(K, first, second);
}
kapply_cc(K, b2tv(res));
}
/* typed finite list. Structure error should be throw before type errors */
void check_typed_list(klisp_State *K, bool (*typep)(TValue), bool allow_infp,
- TValue obj, int32_t *pairs, int32_t *cpairs)
+ TValue obj, int32_t *pairs, int32_t *cpairs)
{
TValue tail = obj;
int32_t p = 0;
bool type_errorp = false;
while(ttispair(tail) && !kis_marked(tail)) {
- /* even if there is a type error continue checking the structure */
- type_errorp |= !(*typep)(kcar(tail));
- kset_mark(tail, i2tv(p));
- tail = kcdr(tail);
- ++p;
+ /* even if there is a type error continue checking the structure */
+ type_errorp |= !(*typep)(kcar(tail));
+ kset_mark(tail, i2tv(p));
+ tail = kcdr(tail);
+ ++p;
}
if (pairs != NULL) *pairs = p;
if (cpairs != NULL)
- *cpairs = ttispair(tail)? (p - ivalue(kget_mark(tail))) : 0;
+ *cpairs = ttispair(tail)? (p - ivalue(kget_mark(tail))) : 0;
unmark_list(K, obj);
if (!ttispair(tail) && !ttisnil(tail)) {
- klispE_throw_simple(K, allow_infp? "expected list" :
- "expected finite list");
- return;
+ klispE_throw_simple(K, allow_infp? "expected list" :
+ "expected finite list");
+ return;
} else if(ttispair(tail) && !allow_infp) {
- klispE_throw_simple(K, "expected finite list");
- return;
+ klispE_throw_simple(K, "expected finite list");
+ return;
} else if (type_errorp) {
- /* TODO put type name too, should be extracted from a
- table of type names */
- klispE_throw_simple(K, "bad operand type");
- return;
+ /* TODO put type name too, should be extracted from a
+ table of type names */
+ klispE_throw_simple(K, "bad operand type");
+ return;
}
}
void check_list(klisp_State *K, bool allow_infp, TValue obj,
- int32_t *pairs, int32_t *cpairs)
+ int32_t *pairs, int32_t *cpairs)
{
TValue tail = obj;
int32_t p = 0;
while(ttispair(tail) && !kis_marked(tail)) {
- kset_mark(tail, i2tv(p));
- tail = kcdr(tail);
- ++p;
+ kset_mark(tail, i2tv(p));
+ tail = kcdr(tail);
+ ++p;
}
if (pairs != NULL) *pairs = p;
if (cpairs != NULL)
- *cpairs = ttispair(tail)? (p - ivalue(kget_mark(tail))) : 0;
+ *cpairs = ttispair(tail)? (p - ivalue(kget_mark(tail))) : 0;
unmark_list(K, obj);
if (!ttispair(tail) && !ttisnil(tail)) {
- klispE_throw_simple(K, allow_infp? "expected list" :
- "expected finite list");
- return;
+ klispE_throw_simple(K, allow_infp? "expected list" :
+ "expected finite list");
+ return;
} else if(ttispair(tail) && !allow_infp) {
- klispE_throw_simple(K, "expected finite list");
- return;
+ klispE_throw_simple(K, "expected finite list");
+ return;
}
}
TValue check_copy_list(klisp_State *K, TValue obj, bool force_copy,
- int32_t *pairs, int32_t *cpairs)
+ int32_t *pairs, int32_t *cpairs)
{
int32_t p = 0;
if (ttisnil(obj)) {
- if (pairs != NULL) *pairs = 0;
- if (cpairs != NULL) *cpairs = 0;
- return obj;
+ if (pairs != NULL) *pairs = 0;
+ if (cpairs != NULL) *cpairs = 0;
+ return obj;
}
if (ttispair(obj) && kis_immutable(obj) && !force_copy) {
- /* this will properly set pairs and cpairs */
- check_list(K, true, obj, pairs, cpairs);
- return obj;
+ /* this will properly set pairs and cpairs */
+ check_list(K, true, obj, pairs, cpairs);
+ return obj;
} else {
- TValue copy = kcons(K, KNIL, KNIL);
- krooted_vars_push(K, ©);
- TValue last_pair = copy;
- TValue tail = obj;
+ TValue copy = kcons(K, KNIL, KNIL);
+ krooted_vars_push(K, ©);
+ TValue last_pair = copy;
+ TValue tail = obj;
- while(ttispair(tail) && !kis_marked(tail)) {
- TValue new_pair = kcons(K, kcar(tail), KNIL);
- /* record the corresponding pair to simplify cycle handling */
- kset_mark(tail, new_pair);
- /* record the pair number in the new pair, to set cpairs */
- kset_mark(new_pair, i2tv(p));
- /* copy the source code info */
- TValue si = ktry_get_si(K, tail);
- if (!ttisnil(si))
- kset_source_info(K, new_pair, si);
- kset_cdr(last_pair, new_pair);
- last_pair = new_pair;
- tail = kcdr(tail);
- ++p;
- }
-
- if (pairs != NULL) *pairs = p;
- if (cpairs != NULL)
- *cpairs = ttispair(tail)?
- (p - ivalue(kget_mark(kget_mark(tail)))) :
- 0;
-
- if (ttispair(tail)) {
- /* complete the cycle */
- kset_cdr(last_pair, kget_mark(tail));
- }
-
- unmark_list(K, obj);
- unmark_list(K, kcdr(copy));
-
- if (!ttispair(tail) && !ttisnil(tail)) {
- klispE_throw_simple(K, "expected list");
- return KINERT;
- }
- krooted_vars_pop(K);
- return kcdr(copy);
+ while(ttispair(tail) && !kis_marked(tail)) {
+ TValue new_pair = kcons(K, kcar(tail), KNIL);
+ /* record the corresponding pair to simplify cycle handling */
+ kset_mark(tail, new_pair);
+ /* record the pair number in the new pair, to set cpairs */
+ kset_mark(new_pair, i2tv(p));
+ /* copy the source code info */
+ TValue si = ktry_get_si(K, tail);
+ if (!ttisnil(si))
+ kset_source_info(K, new_pair, si);
+ kset_cdr(last_pair, new_pair);
+ last_pair = new_pair;
+ tail = kcdr(tail);
+ ++p;
+ }
+
+ if (pairs != NULL) *pairs = p;
+ if (cpairs != NULL)
+ *cpairs = ttispair(tail)?
+ (p - ivalue(kget_mark(kget_mark(tail)))) :
+ 0;
+
+ if (ttispair(tail)) {
+ /* complete the cycle */
+ kset_cdr(last_pair, kget_mark(tail));
+ }
+
+ unmark_list(K, obj);
+ unmark_list(K, kcdr(copy));
+
+ if (!ttispair(tail) && !ttisnil(tail)) {
+ klispE_throw_simple(K, "expected list");
+ return KINERT;
+ }
+ krooted_vars_pop(K);
+ return kcdr(copy);
}
}
@@ -518,32 +518,32 @@ TValue check_copy_env_list(klisp_State *K, TValue obj)
TValue tail = obj;
while(ttispair(tail) && !kis_marked(tail)) {
- TValue first = kcar(tail);
- if (!ttisenvironment(first)) {
- klispE_throw_simple(K, "not an environment in parent list");
- return KINERT;
- }
- TValue new_pair = kcons(K, first, KNIL);
- kmark(tail);
- kset_cdr(last_pair, new_pair);
- last_pair = new_pair;
- tail = kcdr(tail);
+ TValue first = kcar(tail);
+ if (!ttisenvironment(first)) {
+ klispE_throw_simple(K, "not an environment in parent list");
+ return KINERT;
+ }
+ TValue new_pair = kcons(K, first, KNIL);
+ kmark(tail);
+ kset_cdr(last_pair, new_pair);
+ last_pair = new_pair;
+ tail = kcdr(tail);
}
/* even if there was a cycle, the copy ends with nil */
unmark_list(K, obj);
if (!ttispair(tail) && !ttisnil(tail)) {
- klispE_throw_simple(K, "expected list");
- return KINERT;
+ klispE_throw_simple(K, "expected list");
+ return KINERT;
}
krooted_vars_pop(K);
return kcdr(copy);
}
/* Helpers for string, list->string, and string-map,
- bytevector, list->bytevector, bytevector-map,
- vector, list->vector, and vector-map */
+ bytevector, list->bytevector, bytevector-map,
+ vector, list->vector, and vector-map */
/* GC: Assume ls is rooted */
/* ls should a list of length 'length' of the correct type
(chars for string, u8 for bytevector, any for vector) */
@@ -554,21 +554,21 @@ TValue list_to_string_h(klisp_State *K, TValue ls, int32_t length)
TValue new_str;
/* the if isn't strictly necessary but it's clearer this way */
if (length == 0) {
- return K->empty_string;
+ return K->empty_string;
} else {
- new_str = kstring_new_s(K, length);
- char *buf = kstring_buf(new_str);
- while(length-- > 0) {
- TValue head = kcar(ls);
- if (!ttischar(head)) {
- klispE_throw_simple_with_irritants(K, "Bad type (expected "
- "char)", 1, head);
- return KINERT;
- }
- *buf++ = chvalue(head);
- ls = kcdr(ls);
- }
- return new_str;
+ new_str = kstring_new_s(K, length);
+ char *buf = kstring_buf(new_str);
+ while(length-- > 0) {
+ TValue head = kcar(ls);
+ if (!ttischar(head)) {
+ klispE_throw_simple_with_irritants(K, "Bad type (expected "
+ "char)", 1, head);
+ return KINERT;
+ }
+ *buf++ = chvalue(head);
+ ls = kcdr(ls);
+ }
+ return new_str;
}
}
@@ -579,7 +579,7 @@ TValue list_to_vector_h(klisp_State *K, TValue ls, int32_t length)
return K->empty_vector;
} else {
TValue new_vec = kvector_new_sf(K, length, KINERT);
- TValue *buf = kvector_buf(new_vec);
+ TValue *buf = kvector_buf(new_vec);
while(length-- > 0) {
*buf++ = kcar(ls);
ls = kcdr(ls);
@@ -593,21 +593,21 @@ TValue list_to_bytevector_h(klisp_State *K, TValue ls, int32_t length)
TValue new_bb;
/* the if isn't strictly necessary but it's clearer this way */
if (length == 0) {
- return K->empty_bytevector;
+ return K->empty_bytevector;
} else {
- new_bb = kbytevector_new_s(K, length);
- uint8_t *buf = kbytevector_buf(new_bb);
- while(length-- > 0) {
- TValue head = kcar(ls);
- if (!ttisu8(head)) {
- klispE_throw_simple_with_irritants(K, "Bad type (expected "
- "u8)", 1, head);
- return KINERT;
- }
- *buf++ = ivalue(head);
- ls = kcdr(ls);
- }
- return new_bb;
+ new_bb = kbytevector_new_s(K, length);
+ uint8_t *buf = kbytevector_buf(new_bb);
+ while(length-- > 0) {
+ TValue head = kcar(ls);
+ if (!ttisu8(head)) {
+ klispE_throw_simple_with_irritants(K, "Bad type (expected "
+ "u8)", 1, head);
+ return KINERT;
+ }
+ *buf++ = ivalue(head);
+ ls = kcdr(ls);
+ }
+ return new_bb;
}
}
@@ -618,9 +618,9 @@ TValue list_to_bytevector_h(klisp_State *K, TValue ls, int32_t length)
TValue string_to_list_h(klisp_State *K, TValue obj, int32_t *length)
{
if (!ttisstring(obj)) {
- klispE_throw_simple_with_irritants(K, "Bad type (expected string)",
- 1, obj);
- return KINERT;
+ klispE_throw_simple_with_irritants(K, "Bad type (expected string)",
+ 1, obj);
+ return KINERT;
}
int32_t pairs = kstring_size(obj);
@@ -630,8 +630,8 @@ TValue string_to_list_h(klisp_State *K, TValue obj, int32_t *length)
TValue tail = KNIL;
krooted_vars_push(K, &tail);
while(pairs-- > 0) {
- tail = kcons(K, ch2tv(*buf), tail);
- --buf;
+ tail = kcons(K, ch2tv(*buf), tail);
+ --buf;
}
krooted_vars_pop(K);
return tail;
@@ -640,9 +640,9 @@ TValue string_to_list_h(klisp_State *K, TValue obj, int32_t *length)
TValue vector_to_list_h(klisp_State *K, TValue obj, int32_t *length)
{
if (!ttisvector(obj)) {
- klispE_throw_simple_with_irritants(K, "Bad type (expected vector)",
- 1, obj);
- return KINERT;
+ klispE_throw_simple_with_irritants(K, "Bad type (expected vector)",
+ 1, obj);
+ return KINERT;
}
int32_t pairs = kvector_size(obj);
@@ -652,8 +652,8 @@ TValue vector_to_list_h(klisp_State *K, TValue obj, int32_t *length)
TValue tail = KNIL;
krooted_vars_push(K, &tail);
while(pairs-- > 0) {
- tail = kcons(K, *buf, tail);
- --buf;
+ tail = kcons(K, *buf, tail);
+ --buf;
}
krooted_vars_pop(K);
return tail;
@@ -662,9 +662,9 @@ TValue vector_to_list_h(klisp_State *K, TValue obj, int32_t *length)
TValue bytevector_to_list_h(klisp_State *K, TValue obj, int32_t *length)
{
if (!ttisbytevector(obj)) {
- klispE_throw_simple_with_irritants(K, "Bad type (expected bytevector)",
- 1, obj);
- return KINERT;
+ klispE_throw_simple_with_irritants(K, "Bad type (expected bytevector)",
+ 1, obj);
+ return KINERT;
}
int32_t pairs = kbytevector_size(obj);
@@ -674,8 +674,8 @@ TValue bytevector_to_list_h(klisp_State *K, TValue obj, int32_t *length)
TValue tail = KNIL;
krooted_vars_push(K, &tail);
while(pairs-- > 0) {
- tail = kcons(K, i2tv(*buf), tail);
- --buf;
+ tail = kcons(K, i2tv(*buf), tail);
+ --buf;
}
krooted_vars_pop(K);
return tail;
@@ -694,29 +694,29 @@ int64_t kgcd32_64(int32_t a_, int32_t b_)
int powerof2;
/* the easy cases first, unlike the general kernel gcd the
- gcd2 of a number and zero is zero */
+ gcd2 of a number and zero is zero */
if (a == 0)
- return (int64_t) b;
+ return (int64_t) b;
else if (b == 0)
- return (int64_t) a;
+ return (int64_t) a;
for (powerof2 = 0; ((a & 1) == 0) &&
- ((b & 1) == 0); ++powerof2, a >>= 1, b >>= 1)
- ;
+ ((b & 1) == 0); ++powerof2, a >>= 1, b >>= 1)
+ ;
while(a != 0 && b!= 0) {
- /* either a or b are odd, make them both odd */
- for (; (a & 1) == 0; a >>= 1)
- ;
- for (; (b & 1) == 0; b >>= 1)
- ;
-
- /* now the difference is sure to be even */
- if (a < b) {
- b = (b - a) >> 1;
- } else {
- a = (a - b) >> 1;
- }
+ /* either a or b are odd, make them both odd */
+ for (; (a & 1) == 0; a >>= 1)
+ ;
+ for (; (b & 1) == 0; b >>= 1)
+ ;
+
+ /* now the difference is sure to be even */
+ if (a < b) {
+ b = (b - a) >> 1;
+ } else {
+ a = (a - b) >> 1;
+ }
}
return ((int64_t) (a == 0? b : a)) << powerof2;
@@ -763,32 +763,32 @@ void list(klisp_State *K)
/* Helper for get-list-metrics, and list-tail, list-ref and list-set!
when receiving bigint indexes */
void get_list_metrics_aux(klisp_State *K, TValue obj, int32_t *p, int32_t *n,
- int32_t *a, int32_t *c)
+ int32_t *a, int32_t *c)
{
TValue tail = obj;
int32_t pairs = 0;
while(ttispair(tail) && !kis_marked(tail)) {
- /* record the pair number to simplify cycle pair counting */
- kset_mark(tail, i2tv(pairs));
- ++pairs;
- tail = kcdr(tail);
+ /* record the pair number to simplify cycle pair counting */
+ kset_mark(tail, i2tv(pairs));
+ ++pairs;
+ tail = kcdr(tail);
}
int32_t apairs, cpairs, nils;
if (ttisnil(tail)) {
- /* simple (possibly empty) list */
- apairs = pairs;
- nils = 1;
- cpairs = 0;
+ /* simple (possibly empty) list */
+ apairs = pairs;
+ nils = 1;
+ cpairs = 0;
} else if (ttispair(tail)) {
- /* cyclic (maybe circular) list */
- apairs = ivalue(kget_mark(tail));
- cpairs = pairs - apairs;
- nils = 0;
+ /* cyclic (maybe circular) list */
+ apairs = ivalue(kget_mark(tail));
+ cpairs = pairs - apairs;
+ nils = 0;
} else {
- apairs = pairs;
- cpairs = 0;
- nils = 0;
+ apairs = pairs;
+ cpairs = 0;
+ nils = 0;
}
unmark_list(K, obj);
@@ -810,9 +810,9 @@ int32_t ksmallest_index(klisp_State *K, TValue obj, TValue tk)
int32_t apairs, cpairs;
get_list_metrics_aux(K, obj, NULL, NULL, &apairs, &cpairs);
if (cpairs == 0) {
- klispE_throw_simple(K, "non pair found while traversing "
- "object");
- return 0;
+ klispE_throw_simple(K, "non pair found while traversing "
+ "object");
+ return 0;
}
TValue tv_apairs = i2tv(apairs);
TValue tv_cpairs = i2tv(cpairs);
@@ -837,32 +837,32 @@ bool eq2p(klisp_State *K, TValue obj1, TValue obj2)
{
bool res = (tv_equal(obj1, obj2));
if (!res && (ttype(obj1) == ttype(obj2))) {
- switch (ttype(obj1)) {
- case K_TSYMBOL:
+ switch (ttype(obj1)) {
+ case K_TSYMBOL:
/* symbols can't be compared with tv_equal! */
- res = tv_sym_equal(obj1, obj2);
- break;
- case K_TAPPLICATIVE:
- while(ttisapplicative(obj1) && ttisapplicative(obj2)) {
- obj1 = kunwrap(obj1);
- obj2 = kunwrap(obj2);
- }
- res = (tv_equal(obj1, obj2));
- break;
- case K_TBIGINT:
- /* it's important to know that it can't be the case
- that obj1 is bigint and obj is some other type and
- (eq? obj1 obj2) */
- res = kbigint_eqp(obj1, obj2);
- break;
- case K_TBIGRAT:
- /* it's important to know that it can't be the case
- that obj1 is bigrat and obj is some other type and
- (eq? obj1 obj2) */
- res = kbigrat_eqp(K, obj1, obj2);
- break;
- } /* immutable strings & bytevectors are interned so they are
- covered already by tv_equalp */
+ res = tv_sym_equal(obj1, obj2);
+ break;
+ case K_TAPPLICATIVE:
+ while(ttisapplicative(obj1) && ttisapplicative(obj2)) {
+ obj1 = kunwrap(obj1);
+ obj2 = kunwrap(obj2);
+ }
+ res = (tv_equal(obj1, obj2));
+ break;
+ case K_TBIGINT:
+ /* it's important to know that it can't be the case
+ that obj1 is bigint and obj is some other type and
+ (eq? obj1 obj2) */
+ res = kbigint_eqp(obj1, obj2);
+ break;
+ case K_TBIGRAT:
+ /* it's important to know that it can't be the case
+ that obj1 is bigrat and obj is some other type and
+ (eq? obj1 obj2) */
+ res = kbigrat_eqp(K, obj1, obj2);
+ break;
+ } /* immutable strings & bytevectors are interned so they are
+ covered already by tv_equalp */
}
return res;
@@ -891,31 +891,31 @@ inline TValue equal_find(klisp_State *K, TValue obj)
{
/* GC: should root obj */
if (kis_unmarked(obj)) {
- /* object wasn't compared before, create new set */
- TValue new_node = kcons(K, KTRUE, i2tv(1));
- kset_mark(obj, new_node);
- return new_node;
+ /* object wasn't compared before, create new set */
+ TValue new_node = kcons(K, KTRUE, i2tv(1));
+ kset_mark(obj, new_node);
+ return new_node;
} else {
- TValue node = kget_mark(obj);
-
- /* First obtain the root and a list of all the other objects in this
- branch, as said above the root is the one with #t in its car */
- /* NOTE: the stack is being used, so we must remember how many pairs we
- push, we can't just pop 'till is empty */
- int np = 0;
- while(kis_false(kcar(node))) {
- ks_spush(K, node);
- node = kcdr(node);
- ++np;
- }
- TValue root = node;
-
- /* set all parents to root, to flatten the branch */
- while(np--) {
- node = ks_spop(K);
- kset_cdr(node, root);
- }
- return root;
+ TValue node = kget_mark(obj);
+
+ /* First obtain the root and a list of all the other objects in this
+ branch, as said above the root is the one with #t in its car */
+ /* NOTE: the stack is being used, so we must remember how many pairs we
+ push, we can't just pop 'till is empty */
+ int np = 0;
+ while(kis_false(kcar(node))) {
+ ks_spush(K, node);
+ node = kcdr(node);
+ ++np;
+ }
+ TValue root = node;
+
+ /* set all parents to root, to flatten the branch */
+ while(np--) {
+ node = ks_spop(K);
+ kset_cdr(node, root);
+ }
+ return root;
}
}
@@ -929,15 +929,15 @@ inline void equal_merge(klisp_State *K, TValue root1, TValue root2)
TValue new_size = i2tv(size1 + size2);
if (size1 < size2) {
- /* add root1 set (the smaller one) to root2 */
- kset_cdr(root2, new_size);
- kset_car(root1, KFALSE);
- kset_cdr(root1, root2);
+ /* add root1 set (the smaller one) to root2 */
+ kset_cdr(root2, new_size);
+ kset_car(root1, KFALSE);
+ kset_cdr(root1, root2);
} else {
- /* add root2 set (the smaller one) to root1 */
- kset_cdr(root1, new_size);
- kset_car(root2, KFALSE);
- kset_cdr(root2, root1);
+ /* add root2 set (the smaller one) to root1 */
+ kset_cdr(root1, new_size);
+ kset_car(root2, KFALSE);
+ kset_cdr(root2, root1);
}
}
@@ -949,11 +949,11 @@ inline bool equal_find2_mergep(klisp_State *K, TValue obj1, TValue obj2)
TValue root1 = equal_find(K, obj1);
TValue root2 = equal_find(K, obj2);
if (tv_equal(root1, root2)) {
- /* they are in the same set => they were already compared */
- return true;
+ /* they are in the same set => they were already compared */
+ return true;
} else {
- equal_merge(K, root1, root2);
- return false;
+ equal_merge(K, root1, root2);
+ return false;
}
}
@@ -985,65 +985,65 @@ bool equal2p(klisp_State *K, TValue obj1, TValue obj2)
TValue saved_obj2 = obj2;
while(!ks_sisempty(K)) {
- obj2 = ks_spop(K);
- obj1 = ks_spop(K);
-
- if (!eq2p(K, obj1, obj2)) {
- /* This type comparison works because we just care about
- pairs, vectors, strings & bytevectors */
- if (ttype(obj1) == ttype(obj2)) {
- switch(ttype(obj1)) {
- case K_TPAIR:
- /* if they were already compaired, consider equal for
- now otherwise they are equal if both their cars
- and cdrs are */
- if (!equal_find2_mergep(K, obj1, obj2)) {
- ks_spush(K, kcdr(obj1));
- ks_spush(K, kcdr(obj2));
- ks_spush(K, kcar(obj1));
- ks_spush(K, kcar(obj2));
- }
- break;
- case K_TVECTOR:
- if (kvector_size(obj1) == kvector_size(obj2)) {
- /* if they were already compaired, consider equal for
- now otherwise they are equal if all their elements
- are equal pairwise */
- if (!equal_find2_mergep(K, obj1, obj2)) {
- uint32_t i = kvector_size(obj1);
- TValue *array1 = kvector_buf(obj1);
- TValue *array2 = kvector_buf(obj2);
- while(i-- > 0) {
- ks_spush(K, array1[i]);
- ks_spush(K, array2[i]);
- }
- }
- } else {
- result = false;
- goto end;
- }
- break;
- case K_TSTRING:
- if (!kstring_equalp(obj1, obj2)) {
- result = false;
- goto end;
- }
- break;
- case K_TBYTEVECTOR:
- if (!kbytevector_equalp(obj1, obj2)) {
- result = false;
- goto end;
- }
- break;
- default:
- result = false;
- goto end;
- }
- } else {
- result = false;
- goto end;
- }
- }
+ obj2 = ks_spop(K);
+ obj1 = ks_spop(K);
+
+ if (!eq2p(K, obj1, obj2)) {
+ /* This type comparison works because we just care about
+ pairs, vectors, strings & bytevectors */
+ if (ttype(obj1) == ttype(obj2)) {
+ switch(ttype(obj1)) {
+ case K_TPAIR:
+ /* if they were already compaired, consider equal for
+ now otherwise they are equal if both their cars
+ and cdrs are */
+ if (!equal_find2_mergep(K, obj1, obj2)) {
+ ks_spush(K, kcdr(obj1));
+ ks_spush(K, kcdr(obj2));
+ ks_spush(K, kcar(obj1));
+ ks_spush(K, kcar(obj2));
+ }
+ break;
+ case K_TVECTOR:
+ if (kvector_size(obj1) == kvector_size(obj2)) {
+ /* if they were already compaired, consider equal for
+ now otherwise they are equal if all their elements
+ are equal pairwise */
+ if (!equal_find2_mergep(K, obj1, obj2)) {
+ uint32_t i = kvector_size(obj1);
+ TValue *array1 = kvector_buf(obj1);
+ TValue *array2 = kvector_buf(obj2);
+ while(i-- > 0) {
+ ks_spush(K, array1[i]);
+ ks_spush(K, array2[i]);
+ }
+ }
+ } else {
+ result = false;
+ goto end;
+ }
+ break;
+ case K_TSTRING:
+ if (!kstring_equalp(obj1, obj2)) {
+ result = false;
+ goto end;
+ }
+ break;
+ case K_TBYTEVECTOR:
+ if (!kbytevector_equalp(obj1, obj2)) {
+ result = false;
+ goto end;
+ }
+ break;
+ default:
+ result = false;
+ goto end;
+ }
+ } else {
+ result = false;
+ goto end;
+ }
+ }
}
end:
/* if result is false, the stack may not be empty */
@@ -1084,51 +1084,51 @@ TValue copy_es_immutable_h(klisp_State *K, TValue obj, bool mut_flag)
ks_tbpush(K, ST_PUSH);
while(!ks_sisempty(K)) {
- char state = ks_tbpop(K);
- TValue top = ks_spop(K);
-
- if (state == ST_PUSH) {
- /* if the pair is immutable & we are constructing immutable
- pairs there is no need to copy */
- if (ttispair(top) && (mut_flag || kis_mutable(top))) {
- if (kis_marked(top)) {
- /* this pair was already seen, use the same */
- copy = kget_mark(top);
- } else {
- TValue new_pair = kcons_g(K, mut_flag, KINERT, KINERT);
- kset_mark(top, new_pair);
- /* save the source code info on the new pair */
- /* MAYBE: only do it if mutable */
- TValue si = ktry_get_si(K, top);
- if (!ttisnil(si))
- kset_source_info(K, new_pair, si);
- /* leave the pair in the stack, continue with the car */
- ks_spush(K, top);
- ks_tbpush(K, ST_CAR);
+ char state = ks_tbpop(K);
+ TValue top = ks_spop(K);
+
+ if (state == ST_PUSH) {
+ /* if the pair is immutable & we are constructing immutable
+ pairs there is no need to copy */
+ if (ttispair(top) && (mut_flag || kis_mutable(top))) {
+ if (kis_marked(top)) {
+ /* this pair was already seen, use the same */
+ copy = kget_mark(top);
+ } else {
+ TValue new_pair = kcons_g(K, mut_flag, KINERT, KINERT);
+ kset_mark(top, new_pair);
+ /* save the source code info on the new pair */
+ /* MAYBE: only do it if mutable */
+ TValue si = ktry_get_si(K, top);
+ if (!ttisnil(si))
+ kset_source_info(K, new_pair, si);
+ /* leave the pair in the stack, continue with the car */
+ ks_spush(K, top);
+ ks_tbpush(K, ST_CAR);
- ks_spush(K, kcar(top));
- ks_tbpush(K, ST_PUSH);
- }
- } else {
- copy = top;
- }
- } else { /* last action was a pop */
- TValue new_pair = kget_mark(top);
- if (state == ST_CAR) {
- /* new_pair may be immutable */
- kset_car_unsafe(K, new_pair, copy);
- /* leave the pair on the stack, continue with the cdr */
- ks_spush(K, top);
- ks_tbpush(K, ST_CDR);
-
- ks_spush(K, kcdr(top));
- ks_tbpush(K, ST_PUSH);
- } else {
- /* new_pair may be immutable */
- kset_cdr_unsafe(K, new_pair, copy);
- copy = new_pair;
- }
- }
+ ks_spush(K, kcar(top));
+ ks_tbpush(K, ST_PUSH);
+ }
+ } else {
+ copy = top;
+ }
+ } else { /* last action was a pop */
+ TValue new_pair = kget_mark(top);
+ if (state == ST_CAR) {
+ /* new_pair may be immutable */
+ kset_car_unsafe(K, new_pair, copy);
+ /* leave the pair on the stack, continue with the cdr */
+ ks_spush(K, top);
+ ks_tbpush(K, ST_CDR);
+
+ ks_spush(K, kcdr(top));
+ ks_tbpush(K, ST_PUSH);
+ } else {
+ /* new_pair may be immutable */
+ kset_cdr_unsafe(K, new_pair, copy);
+ copy = new_pair;
+ }
+ }
}
unmark_tree(K, obj);
krooted_vars_pop(K);
@@ -1145,14 +1145,14 @@ TValue copy_es_immutable_h(klisp_State *K, TValue obj, bool mut_flag)
inline void ptree_clear_all(klisp_State *K, TValue sym_ls)
{
while(!ttisnil(sym_ls)) {
- TValue first = sym_ls;
- sym_ls = kget_symbol_mark(first);
- kunmark_symbol(first);
+ TValue first = sym_ls;
+ sym_ls = kget_symbol_mark(first);
+ kunmark_symbol(first);
}
while(!ks_sisempty(K)) {
- kunmark(ks_sget(K));
- ks_sdpop(K);
+ kunmark(ks_sget(K));
+ ks_sdpop(K);
}
ks_tbclear(K);
@@ -1166,41 +1166,41 @@ void match(klisp_State *K, TValue env, TValue ptree, TValue obj)
ks_spush(K, ptree);
while(!ks_sisempty(K)) {
- ptree = ks_spop(K);
- obj = ks_spop(K);
-
- switch(ttype(ptree)) {
- case K_TNIL:
- if (!ttisnil(obj)) {
- /* TODO show ptree and arguments */
- ks_sclear(K);
- klispE_throw_simple(K, "ptree doesn't match arguments");
- return;
- }
- break;
- case K_TIGNORE:
- /* do nothing */
- break;
- case K_TSYMBOL:
- kadd_binding(K, env, ptree, obj);
- break;
- case K_TPAIR:
- if (ttispair(obj)) {
- ks_spush(K, kcdr(obj));
- ks_spush(K, kcdr(ptree));
- ks_spush(K, kcar(obj));
- ks_spush(K, kcar(ptree));
- } else {
- /* TODO show ptree and arguments */
- ks_sclear(K);
- klispE_throw_simple(K, "ptree doesn't match arguments");
- return;
- }
- break;
- default:
- /* can't really happen */
- break;
- }
+ ptree = ks_spop(K);
+ obj = ks_spop(K);
+
+ switch(ttype(ptree)) {
+ case K_TNIL:
+ if (!ttisnil(obj)) {
+ /* TODO show ptree and arguments */
+ ks_sclear(K);
+ klispE_throw_simple(K, "ptree doesn't match arguments");
+ return;
+ }
+ break;
+ case K_TIGNORE:
+ /* do nothing */
+ break;
+ case K_TSYMBOL:
+ kadd_binding(K, env, ptree, obj);
+ break;
+ case K_TPAIR:
+ if (ttispair(obj)) {
+ ks_spush(K, kcdr(obj));
+ ks_spush(K, kcdr(ptree));
+ ks_spush(K, kcar(obj));
+ ks_spush(K, kcar(ptree));
+ } else {
+ /* TODO show ptree and arguments */
+ ks_sclear(K);
+ klispE_throw_simple(K, "ptree doesn't match arguments");
+ return;
+ }
+ break;
+ default:
+ /* can't really happen */
+ break;
+ }
}
}
@@ -1225,115 +1225,115 @@ TValue check_copy_ptree(klisp_State *K, TValue ptree, TValue penv)
ks_spush(K, ptree);
while(!ks_sisempty(K)) {
- char state = ks_tbpop(K);
- TValue top = ks_spop(K);
-
- if (state == ST_PUSH) {
- switch(ttype(top)) {
- case K_TIGNORE:
- case K_TNIL:
- copy = top;
- break;
- case K_TSYMBOL: {
- if (kis_symbol_marked(top)) {
- ptree_clear_all(K, sym_ls);
- klispE_throw_simple_with_irritants(K, "repeated symbol "
- "in ptree", 1, top);
- return KNIL;
- } else {
- copy = top;
- /* add it to the symbol list */
- kset_symbol_mark(top, sym_ls);
- sym_ls = top;
- }
- break;
- }
- case K_TPAIR: {
- if (kis_unmarked(top)) {
- if (kis_immutable(top)) {
- /* don't copy mutable pairs, just use them */
- /* NOTE: immutable pairs can't have mutable
- car or cdr */
- /* we have to continue thou, because there could be a
- cycle */
- kset_mark(top, top);
- } else {
- /* create a new pair as copy, save it in the mark */
- TValue new_pair = kimm_cons(K, KNIL, KNIL);
- kset_mark(top, new_pair);
- /* copy the source code info */
- TValue si = ktry_get_si(K, top);
- if (!ttisnil(si))
- kset_source_info(K, new_pair, si);
- }
- /* keep the old pair and continue with the car */
- ks_tbpush(K, ST_CAR);
- ks_spush(K, top);
-
- ks_tbpush(K, ST_PUSH);
- ks_spush(K, kcar(top));
- } else {
- /* marked pair means a cycle was found */
- /* NOTE: the pair should be in the stack already so
- it isn't necessary to push it again to clear the mark */
- ptree_clear_all(K, sym_ls);
- klispE_throw_simple(K, "cycle detected in ptree");
- /* avoid warning */
- return KNIL;
- }
- break;
- }
- default:
- ptree_clear_all(K, sym_ls);
- klispE_throw_simple(K, "bad object type in ptree");
- /* avoid warning */
- return KNIL;
- }
- } else {
+ char state = ks_tbpop(K);
+ TValue top = ks_spop(K);
+
+ if (state == ST_PUSH) {
+ switch(ttype(top)) {
+ case K_TIGNORE:
+ case K_TNIL:
+ copy = top;
+ break;
+ case K_TSYMBOL: {
+ if (kis_symbol_marked(top)) {
+ ptree_clear_all(K, sym_ls);
+ klispE_throw_simple_with_irritants(K, "repeated symbol "
+ "in ptree", 1, top);
+ return KNIL;
+ } else {
+ copy = top;
+ /* add it to the symbol list */
+ kset_symbol_mark(top, sym_ls);
+ sym_ls = top;
+ }
+ break;
+ }
+ case K_TPAIR: {
+ if (kis_unmarked(top)) {
+ if (kis_immutable(top)) {
+ /* don't copy mutable pairs, just use them */
+ /* NOTE: immutable pairs can't have mutable
+ car or cdr */
+ /* we have to continue thou, because there could be a
+ cycle */
+ kset_mark(top, top);
+ } else {
+ /* create a new pair as copy, save it in the mark */
+ TValue new_pair = kimm_cons(K, KNIL, KNIL);
+ kset_mark(top, new_pair);
+ /* copy the source code info */
+ TValue si = ktry_get_si(K, top);
+ if (!ttisnil(si))
+ kset_source_info(K, new_pair, si);
+ }
+ /* keep the old pair and continue with the car */
+ ks_tbpush(K, ST_CAR);
+ ks_spush(K, top);
+
+ ks_tbpush(K, ST_PUSH);
+ ks_spush(K, kcar(top));
+ } else {
+ /* marked pair means a cycle was found */
+ /* NOTE: the pair should be in the stack already so
+ it isn't necessary to push it again to clear the mark */
+ ptree_clear_all(K, sym_ls);
+ klispE_throw_simple(K, "cycle detected in ptree");
+ /* avoid warning */
+ return KNIL;
+ }
+ break;
+ }
+ default:
+ ptree_clear_all(K, sym_ls);
+ klispE_throw_simple(K, "bad object type in ptree");
+ /* avoid warning */
+ return KNIL;
+ }
+ } else {
/* last operation was a pop */
- /* top is a marked pair, the mark is the copied obj */
- /* NOTE: if top is immutable the mark is also top
- we could still do the set-car/set-cdr because the
- copy would be the same as the car/cdr, but why bother */
- if (state == ST_CAR) {
- /* only car was checked (not yet copied) */
- if (kis_mutable(top)) {
- TValue copied_pair = kget_mark(top);
- /* copied_pair may be immutable */
- kset_car_unsafe(K, copied_pair, copy);
- }
- /* put the copied pair again, continue with the cdr */
- ks_tbpush(K, ST_CDR);
- ks_spush(K, top);
-
- ks_tbpush(K, ST_PUSH);
- ks_spush(K, kcdr(top));
- } else {
+ /* top is a marked pair, the mark is the copied obj */
+ /* NOTE: if top is immutable the mark is also top
+ we could still do the set-car/set-cdr because the
+ copy would be the same as the car/cdr, but why bother */
+ if (state == ST_CAR) {
+ /* only car was checked (not yet copied) */
+ if (kis_mutable(top)) {
+ TValue copied_pair = kget_mark(top);
+ /* copied_pair may be immutable */
+ kset_car_unsafe(K, copied_pair, copy);
+ }
+ /* put the copied pair again, continue with the cdr */
+ ks_tbpush(K, ST_CDR);
+ ks_spush(K, top);
+
+ ks_tbpush(K, ST_PUSH);
+ ks_spush(K, kcdr(top));
+ } else {
/* both car & cdr were checked (cdr not yet copied) */
- TValue copied_pair = kget_mark(top);
- /* the unmark is needed to allow diamonds */
- kunmark(top);
-
- if (kis_mutable(top)) {
- /* copied_pair may be immutable */
- kset_cdr_unsafe(K, copied_pair, copy);
- }
- copy = copied_pair;
- }
- }
+ TValue copied_pair = kget_mark(top);
+ /* the unmark is needed to allow diamonds */
+ kunmark(top);
+
+ if (kis_mutable(top)) {
+ /* copied_pair may be immutable */
+ kset_cdr_unsafe(K, copied_pair, copy);
+ }
+ copy = copied_pair;
+ }
+ }
}
if (ttissymbol(penv)) {
- if (kis_symbol_marked(penv)) {
- ptree_clear_all(K, sym_ls);
- klispE_throw_simple_with_irritants(K, "same symbol in both ptree "
- "and environment parameter",
- 1, sym_ls);
- }
+ if (kis_symbol_marked(penv)) {
+ ptree_clear_all(K, sym_ls);
+ klispE_throw_simple_with_irritants(K, "same symbol in both ptree "
+ "and environment parameter",
+ 1, sym_ls);
+ }
} else if (!ttisignore(penv)) {
ptree_clear_all(K, sym_ls);
klispE_throw_simple(K, "symbol or #ignore expected as "
- "environment parmameter");
+ "environment parmameter");
}
ptree_clear_all(K, sym_ls);
krooted_vars_pop(K);
@@ -1342,8 +1342,8 @@ TValue check_copy_ptree(klisp_State *K, TValue ptree, TValue penv)
/* Helpers for map (also used by for each) */
void map_for_each_get_metrics(klisp_State *K, TValue lss,
- int32_t *app_apairs_out, int32_t *app_cpairs_out,
- int32_t *res_apairs_out, int32_t *res_cpairs_out)
+ int32_t *app_apairs_out, int32_t *app_cpairs_out,
+ int32_t *res_apairs_out, int32_t *res_cpairs_out)
{
/* avoid warnings (shouldn't happen if _No_return was used in throw) */
*app_apairs_out = 0;
@@ -1363,52 +1363,52 @@ void map_for_each_get_metrics(klisp_State *K, TValue lss,
int32_t res_apairs = res_pairs - res_cpairs;
if (res_cpairs == 0) {
- /* finite list of length res_pairs (all lists should
- have the same structure: acyclic with same length) */
- int32_t pairs = app_pairs - 1;
- TValue tail = kcdr(lss);
- while(pairs--) {
- int32_t first_pairs, first_cpairs;
- check_list(K, true, kcar(tail), &first_pairs, &first_cpairs);
- tail = kcdr(tail);
-
- if (first_cpairs != 0) {
- klispE_throw_simple(K, "mixed finite and infinite lists");
- return;
- } else if (first_pairs != res_pairs) {
- klispE_throw_simple(K, "lists of different length");
- return;
- }
- }
+ /* finite list of length res_pairs (all lists should
+ have the same structure: acyclic with same length) */
+ int32_t pairs = app_pairs - 1;
+ TValue tail = kcdr(lss);
+ while(pairs--) {
+ int32_t first_pairs, first_cpairs;
+ check_list(K, true, kcar(tail), &first_pairs, &first_cpairs);
+ tail = kcdr(tail);
+
+ if (first_cpairs != 0) {
+ klispE_throw_simple(K, "mixed finite and infinite lists");
+ return;
+ } else if (first_pairs != res_pairs) {
+ klispE_throw_simple(K, "lists of different length");
+ return;
+ }
+ }
} else {
- /* cyclic list: all lists should be cyclic.
- result will have acyclic length equal to the
- max of all the lists and cyclic length equal to the lcm
- of all the lists. res_pairs may be broken but will be
- restored by after the loop */
- int32_t pairs = app_pairs - 1;
- TValue tail = kcdr(lss);
- while(pairs--) {
- int32_t first_pairs, first_cpairs;
- check_list(K, true, kcar(tail), &first_pairs, &first_cpairs);
- int32_t first_apairs = first_pairs - first_cpairs;
- tail = kcdr(tail);
-
- if (first_cpairs == 0) {
- klispE_throw_simple(K, "mixed finite and infinite lists");
- return;
- }
- res_apairs = kmax32(res_apairs, first_apairs);
- /* this can throw an error if res_cpairs doesn't
- fit in 32 bits, which is a reasonable implementation
- restriction because the list wouldn't fit in memory
- anyways */
- res_cpairs = kcheck32(K, "map/for-each: result list is too big",
- klcm32_64(res_cpairs, first_cpairs));
- }
- res_pairs = kcheck32(K, "map/for-each: result list is too big",
- (int64_t) res_cpairs + (int64_t) res_apairs);
- UNUSED(res_pairs);
+ /* cyclic list: all lists should be cyclic.
+ result will have acyclic length equal to the
+ max of all the lists and cyclic length equal to the lcm
+ of all the lists. res_pairs may be broken but will be
+ restored by after the loop */
+ int32_t pairs = app_pairs - 1;
+ TValue tail = kcdr(lss);
+ while(pairs--) {
+ int32_t first_pairs, first_cpairs;
+ check_list(K, true, kcar(tail), &first_pairs, &first_cpairs);
+ int32_t first_apairs = first_pairs - first_cpairs;
+ tail = kcdr(tail);
+
+ if (first_cpairs == 0) {
+ klispE_throw_simple(K, "mixed finite and infinite lists");
+ return;
+ }
+ res_apairs = kmax32(res_apairs, first_apairs);
+ /* this can throw an error if res_cpairs doesn't
+ fit in 32 bits, which is a reasonable implementation
+ restriction because the list wouldn't fit in memory
+ anyways */
+ res_cpairs = kcheck32(K, "map/for-each: result list is too big",
+ klcm32_64(res_cpairs, first_cpairs));
+ }
+ res_pairs = kcheck32(K, "map/for-each: result list is too big",
+ (int64_t) res_cpairs + (int64_t) res_apairs);
+ UNUSED(res_pairs);
}
*app_apairs_out = app_apairs;
@@ -1422,7 +1422,7 @@ void map_for_each_get_metrics(klisp_State *K, TValue lss,
/* GC: assumes lss is rooted */
TValue map_for_each_get_cars_cdrs(klisp_State *K, TValue *lss,
- int32_t apairs, int32_t cpairs)
+ int32_t apairs, int32_t cpairs)
{
TValue tail = *lss;
@@ -1437,45 +1437,45 @@ TValue map_for_each_get_cars_cdrs(klisp_State *K, TValue *lss,
TValue lap_cdrs = lp_cdrs;
while(apairs != 0 || cpairs != 0) {
- int32_t pairs;
- if (apairs != 0) {
- pairs = apairs;
- } else {
- /* remember last acyclic pair of both lists to to encycle! later */
- lap_cars = lp_cars;
- lap_cdrs = lp_cdrs;
- pairs = cpairs;
- }
-
- while(pairs--) {
- TValue first = kcar(tail);
- tail = kcdr(tail);
+ int32_t pairs;
+ if (apairs != 0) {
+ pairs = apairs;
+ } else {
+ /* remember last acyclic pair of both lists to to encycle! later */
+ lap_cars = lp_cars;
+ lap_cdrs = lp_cdrs;
+ pairs = cpairs;
+ }
+
+ while(pairs--) {
+ TValue first = kcar(tail);
+ tail = kcdr(tail);
- /* accumulate both cars and cdrs */
- TValue np;
- np = kcons(K, kcar(first), KNIL);
- kset_cdr(lp_cars, np);
- lp_cars = np;
-
- np = kcons(K, kcdr(first), KNIL);
- kset_cdr(lp_cdrs, np);
- lp_cdrs = np;
- }
-
- if (apairs != 0) {
- apairs = 0;
- } else {
- cpairs = 0;
- /* encycle! the list of cars and the list of cdrs */
- TValue fcp, lcp;
- fcp = kcdr(lap_cars);
- lcp = lp_cars;
- kset_cdr(lcp, fcp);
-
- fcp = kcdr(lap_cdrs);
- lcp = lp_cdrs;
- kset_cdr(lcp, fcp);
- }
+ /* accumulate both cars and cdrs */
+ TValue np;
+ np = kcons(K, kcar(first), KNIL);
+ kset_cdr(lp_cars, np);
+ lp_cars = np;
+
+ np = kcons(K, kcdr(first), KNIL);
+ kset_cdr(lp_cdrs, np);
+ lp_cdrs = np;
+ }
+
+ if (apairs != 0) {
+ apairs = 0;
+ } else {
+ cpairs = 0;
+ /* encycle! the list of cars and the list of cdrs */
+ TValue fcp, lcp;
+ fcp = kcdr(lap_cars);
+ lcp = lp_cars;
+ kset_cdr(lcp, fcp);
+
+ fcp = kcdr(lap_cdrs);
+ lcp = lp_cdrs;
+ kset_cdr(lcp, fcp);
+ }
}
krooted_vars_pop(K);
@@ -1490,8 +1490,8 @@ TValue map_for_each_get_cars_cdrs(klisp_State *K, TValue *lss,
/* GC: assumes lss is rooted */
TValue map_for_each_transpose(klisp_State *K, TValue lss,
- int32_t app_apairs, int32_t app_cpairs,
- int32_t res_apairs, int32_t res_cpairs)
+ int32_t app_apairs, int32_t app_cpairs,
+ int32_t res_apairs, int32_t res_cpairs)
{
TValue tlist = kcons(K, KNIL, KNIL);
krooted_vars_push(K, &tlist);
@@ -1510,33 +1510,33 @@ TValue map_for_each_transpose(klisp_State *K, TValue lss,
a list of cdrs, accumulate the list of cars and loop
with the list of cdrs as the new list of lists (lss) */
while(res_apairs != 0 || res_cpairs != 0) {
- int32_t pairs;
+ int32_t pairs;
- if (res_apairs != 0) {
- pairs = res_apairs;
- } else {
- pairs = res_cpairs;
- /* remember last acyclic pair to encycle! later */
- lap = lp;
- }
-
- while(pairs--) {
- /* accumulate cars and replace tail with cdrs */
- cars = map_for_each_get_cars_cdrs(K, &tail, app_apairs, app_cpairs);
- TValue np = kcons(K, cars, KNIL);
- kset_cdr(lp, np);
- lp = np;
- }
-
- if (res_apairs != 0) {
- res_apairs = 0;
- } else {
- res_cpairs = 0;
- /* encycle! the list of list of cars */
- TValue fcp = kcdr(lap);
- TValue lcp = lp;
- kset_cdr(lcp, fcp);
- }
+ if (res_apairs != 0) {
+ pairs = res_apairs;
+ } else {
+ pairs = res_cpairs;
+ /* remember last acyclic pair to encycle! later */
+ lap = lp;
+ }
+
+ while(pairs--) {
+ /* accumulate cars and replace tail with cdrs */
+ cars = map_for_each_get_cars_cdrs(K, &tail, app_apairs, app_cpairs);
+ TValue np = kcons(K, cars, KNIL);
+ kset_cdr(lp, np);
+ lp = np;
+ }
+
+ if (res_apairs != 0) {
+ res_apairs = 0;
+ } else {
+ res_cpairs = 0;
+ /* encycle! the list of list of cars */
+ TValue fcp = kcdr(lap);
+ TValue lcp = lp;
+ kset_cdr(lcp, fcp);
+ }
}
krooted_vars_pop(K);
@@ -1567,13 +1567,13 @@ void do_seq(klisp_State *K)
TValue denv = xparams[1];
if (ttispair(tail)) {
- TValue new_cont = kmake_continuation(K, kget_cc(K), do_seq, 2, tail,
- denv);
- kset_cc(K, new_cont);
+ TValue new_cont = kmake_continuation(K, kget_cc(K), do_seq, 2, tail,
+ denv);
+ kset_cc(K, new_cont);
#if KTRACK_SI
- /* put the source info of the list including the element
- that we are about to evaluate */
- kset_source_info(K, new_cont, ktry_get_si(K, ls));
+ /* put the source info of the list including the element
+ that we are about to evaluate */
+ kset_source_info(K, new_cont, ktry_get_si(K, ls));
#endif
}
ktail_eval(K, first, denv);
@@ -1620,7 +1620,7 @@ void do_bind(klisp_State *K)
** xparams[0]: dynamic key
*/
bind_2tp(K, ptree, "any", anytype, obj,
- "combiner", ttiscombiner, comb);
+ "combiner", ttiscombiner, comb);
UNUSED(denv); /* the combiner is called in an empty environment */
TValue key = xparams[0];
/* GC: root intermediate objs */
@@ -1632,14 +1632,14 @@ void do_bind(klisp_State *K)
kset_car(key, new_flag);
kset_cdr(key, new_value);
/* Old value must be protected from GC. It is no longer
- reachable through key and not yet reachable through
- continuation xparams. Boolean flag needn't be rooted,
- because is not heap-allocated. */
+ reachable through key and not yet reachable through
+ continuation xparams. Boolean flag needn't be rooted,
+ because is not heap-allocated. */
krooted_tvs_push(K, old_value);
/* create a continuation to set the var to the correct value/flag on both
- normal return and abnormal passes */
+ normal return and abnormal passes */
TValue new_cont = make_bind_continuation(K, key, old_flag, old_value,
- new_flag, new_value);
+ new_flag, new_value);
krooted_tvs_pop(K);
kset_cc(K, new_cont); /* implicit rooting */
TValue env = kmake_empty_environment(K);
@@ -1647,7 +1647,7 @@ void do_bind(klisp_State *K)
TValue expr = kcons(K, comb, KNIL);
krooted_tvs_pop(K);
ktail_eval(K, expr, env)
-}
+ }
/* accesor returned */
void do_access(klisp_State *K)
@@ -1664,10 +1664,10 @@ void do_access(klisp_State *K)
TValue key = xparams[0];
if (kis_true(kcar(key))) {
- kapply_cc(K, kcdr(key));
+ kapply_cc(K, kcdr(key));
} else {
- klispE_throw_simple(K, "variable is unbound");
- return;
+ klispE_throw_simple(K, "variable is unbound");
+ return;
}
}
@@ -1728,17 +1728,17 @@ void do_set_pass(klisp_State *K)
/* GC: this assumes that key, old_value and new_value are rooted */
TValue make_bind_continuation(klisp_State *K, TValue key,
- TValue old_flag, TValue old_value,
- TValue new_flag, TValue new_value)
+ TValue old_flag, TValue old_value,
+ TValue new_flag, TValue new_value)
{
TValue unbind_cont = kmake_continuation(K, kget_cc(K),
- do_unbind, 3, key, old_flag,
- old_value);
+ do_unbind, 3, key, old_flag,
+ old_value);
krooted_tvs_push(K, unbind_cont);
/* create the guards to guarantee that the values remain consistent on
abnormal passes (in both directions) */
TValue exit_int = kmake_operative(K, do_set_pass,
- 3, key, old_flag, old_value);
+ 3, key, old_flag, old_value);
krooted_tvs_push(K, exit_int);
TValue exit_guard = kcons(K, K->root_cont, exit_int);
krooted_tvs_pop(K); /* already rooted in guard */
@@ -1748,7 +1748,7 @@ TValue make_bind_continuation(klisp_State *K, TValue key,
krooted_tvs_push(K, exit_guards);
TValue entry_int = kmake_operative(K, do_set_pass,
- 3, key, new_flag, new_value);
+ 3, key, new_flag, new_value);
krooted_tvs_push(K, entry_int);
TValue entry_guard = kcons(K, K->root_cont, entry_int);
krooted_tvs_pop(K); /* already rooted in guard */
@@ -1763,11 +1763,11 @@ TValue make_bind_continuation(klisp_State *K, TValue key,
TValue env = kmake_empty_environment(K);
krooted_tvs_push(K, env);
TValue outer_cont = kmake_continuation(K, unbind_cont,
- do_pass_value, 2, entry_guards, env);
+ do_pass_value, 2, entry_guards, env);
kset_outer_cont(outer_cont);
krooted_tvs_push(K, outer_cont);
TValue inner_cont = kmake_continuation(K, outer_cont,
- do_pass_value, 2, exit_guards, env);
+ do_pass_value, 2, exit_guards, env);
kset_inner_cont(inner_cont);
/* unbind_cont & 2 guard_lists */
@@ -1780,39 +1780,39 @@ TValue make_bind_continuation(klisp_State *K, TValue key,
/* Helpers for guard-continuation (& guard-dynamic-extent) */
-#define singly_wrapped(obj_) (ttisapplicative(obj_) && \
- ttisoperative(kunwrap(obj_)))
+#define singly_wrapped(obj_) (ttisapplicative(obj_) && \
+ ttisoperative(kunwrap(obj_)))
/* this unmarks root before throwing any error */
/* TODO: this isn't very clean, refactor */
/* GC: assumes obj & root are rooted */
inline TValue check_copy_single_entry(klisp_State *K, char *name,
- TValue obj, TValue root)
+ TValue obj, TValue root)
{
if (!ttispair(obj) || !ttispair(kcdr(obj)) ||
!ttisnil(kcddr(obj))) {
- unmark_list(K, root);
- klispE_throw_simple(K, "Bad entry (expected list of length 2)");
- return KINERT;
+ unmark_list(K, root);
+ klispE_throw_simple(K, "Bad entry (expected list of length 2)");
+ return KINERT;
}
TValue cont = kcar(obj);
TValue app = kcadr(obj);
if (!ttiscontinuation(cont)) {
- unmark_list(K, root);
- klispE_throw_simple(K, "Bad type on first element (expected "
- "continuation)");
- return KINERT;
+ unmark_list(K, root);
+ klispE_throw_simple(K, "Bad type on first element (expected "
+ "continuation)");
+ return KINERT;
} else if (!singly_wrapped(app)) {
- unmark_list(K, root);
- klispE_throw_simple(K, "Bad type on second element (expected "
- "singly wrapped applicative)");
- return KINERT;
+ unmark_list(K, root);
+ klispE_throw_simple(K, "Bad type on second element (expected "
+ "singly wrapped applicative)");
+ return KINERT;
}
/* save the operative directly, don't waste space/time
- with a list, use just a pair */
+ with a list, use just a pair */
return kcons(K, cont, kunwrap(app));
}
@@ -1822,34 +1822,34 @@ inline TValue check_copy_single_entry(klisp_State *K, char *name,
TValue check_copy_guards(klisp_State *K, char *name, TValue obj)
{
if (ttisnil(obj)) {
- return obj;
+ return obj;
} else {
- TValue copy = kcons(K, KNIL, KNIL);
- krooted_vars_push(K, ©);
- TValue last_pair = copy;
- TValue tail = obj;
+ TValue copy = kcons(K, KNIL, KNIL);
+ krooted_vars_push(K, ©);
+ TValue last_pair = copy;
+ TValue tail = obj;
- while(ttispair(tail) && !kis_marked(tail)) {
- /* this will clear the marks and throw an error if the structure
- is incorrect */
- TValue entry = check_copy_single_entry(K, name, kcar(tail), obj);
- krooted_tvs_push(K, entry);
- TValue new_pair = kcons(K, entry, KNIL);
- krooted_tvs_pop(K);
- kmark(tail);
- kset_cdr(last_pair, new_pair);
- last_pair = new_pair;
- tail = kcdr(tail);
- }
-
- /* dont close the cycle (if there is one) */
- unmark_list(K, obj);
- if (!ttispair(tail) && !ttisnil(tail)) {
- klispE_throw_simple(K, "expected list");
- return KINERT;
- }
- krooted_vars_pop(K);
- return kcdr(copy);
+ while(ttispair(tail) && !kis_marked(tail)) {
+ /* this will clear the marks and throw an error if the structure
+ is incorrect */
+ TValue entry = check_copy_single_entry(K, name, kcar(tail), obj);
+ krooted_tvs_push(K, entry);
+ TValue new_pair = kcons(K, entry, KNIL);
+ krooted_tvs_pop(K);
+ kmark(tail);
+ kset_cdr(last_pair, new_pair);
+ last_pair = new_pair;
+ tail = kcdr(tail);
+ }
+
+ /* dont close the cycle (if there is one) */
+ unmark_list(K, obj);
+ if (!ttispair(tail) && !ttisnil(tail)) {
+ klispE_throw_simple(K, "expected list");
+ return KINERT;
+ }
+ krooted_vars_pop(K);
+ return kcdr(copy);
}
}
@@ -1862,28 +1862,28 @@ void guard_dynamic_extent(klisp_State *K)
UNUSED(xparams);
bind_3tp(K, ptree, "any", anytype, entry_guards,
- "combiner", ttiscombiner, comb,
- "any", anytype, exit_guards);
+ "combiner", ttiscombiner, comb,
+ "any", anytype, exit_guards);
entry_guards = check_copy_guards(K, "guard-dynamic-extent: entry guards",
- entry_guards);
+ entry_guards);
krooted_tvs_push(K, entry_guards);
exit_guards = check_copy_guards(K, "guard-dynamic-extent: exit guards",
- exit_guards);
+ exit_guards);
krooted_tvs_push(K, exit_guards);
/* GC: root continuations */
/* The current continuation is guarded */
TValue outer_cont = kmake_continuation(K, kget_cc(K), do_pass_value,
- 2, entry_guards, denv);
+ 2, entry_guards, denv);
kset_outer_cont(outer_cont);
kset_cc(K, outer_cont); /* this implicitly roots outer_cont */
TValue inner_cont = kmake_continuation(K, outer_cont, do_pass_value, 2,
- exit_guards, denv);
+ exit_guards, denv);
kset_inner_cont(inner_cont);
/* call combiner with no operands in the dynamic extent of inner,
- with the dynamic env of this call */
+ with the dynamic env of this call */
kset_cc(K, inner_cont); /* this implicitly roots inner_cont */
TValue expr = kcons(K, comb, KNIL);
diff --git a/src/kghelpers.h b/src/kghelpers.h
@@ -77,21 +77,21 @@ bool knegativep(TValue n);
inline bool kfast_zerop(TValue n)
{
return (ttisfixint(n) && ivalue(n) == 0) ||
- (ttisdouble(n) && dvalue(n) == 0.0);
+ (ttisdouble(n) && dvalue(n) == 0.0);
}
inline bool kfast_onep(TValue n)
{
return (ttisfixint(n) && ivalue(n) == 1) ||
- (ttisdouble(n) && dvalue(n) == 1.0);
+ (ttisdouble(n) && dvalue(n) == 1.0);
}
inline TValue kneg_inf(TValue i)
{
if (ttiseinf(i))
- return tv_equal(i, KEPINF)? KEMINF : KEPINF;
+ return tv_equal(i, KEPINF)? KEMINF : KEPINF;
else /* ttisiinf(i) */
- return tv_equal(i, KIPINF)? KIMINF : KIPINF;
+ return tv_equal(i, KIPINF)? KIMINF : KIPINF;
}
inline bool knum_same_signp(klisp_State *K, TValue n1, TValue n2)
@@ -112,162 +112,162 @@ inline bool knum_same_signp(klisp_State *K, TValue n1, TValue n2)
(the same with check_0tp and check_al1tp)
add a number param and use an array of strings for msgs */
-#define check_0p(K_, ptree_) \
- if (!ttisnil(ptree_)) { \
- klispE_throw_simple((K_), \
- "Bad ptree (expected no arguments)"); \
- return; \
+#define check_0p(K_, ptree_) \
+ if (!ttisnil(ptree_)) { \
+ klispE_throw_simple((K_), \
+ "Bad ptree (expected no arguments)"); \
+ return; \
}
-#define bind_1p(K_, ptree_, v_) \
+#define bind_1p(K_, ptree_, v_) \
bind_1tp((K_), (ptree_), "any", anytype, (v_))
-#define bind_1tp(K_, ptree_, tstr_, t_, v_) \
- TValue v_; \
- if (!ttispair(ptree_) || !ttisnil(kcdr(ptree_))) { \
- klispE_throw_simple((K_), \
- "Bad ptree (expected one argument)"); \
- return; \
- } \
- v_ = kcar(ptree_); \
- if (!t_(v_)) { \
- klispE_throw_simple(K_, "Bad type on first argument " \
- "(expected " tstr_ ")"); \
- return; \
+#define bind_1tp(K_, ptree_, tstr_, t_, v_) \
+ TValue v_; \
+ if (!ttispair(ptree_) || !ttisnil(kcdr(ptree_))) { \
+ klispE_throw_simple((K_), \
+ "Bad ptree (expected one argument)"); \
+ return; \
+ } \
+ v_ = kcar(ptree_); \
+ if (!t_(v_)) { \
+ klispE_throw_simple(K_, "Bad type on first argument " \
+ "(expected " tstr_ ")"); \
+ return; \
}
-#define bind_2p(K_, ptree_, v1_, v2_) \
+#define bind_2p(K_, ptree_, v1_, v2_) \
bind_2tp((K_), (ptree_), "any", anytype, (v1_), \
- "any", anytype, (v2_))
-
-#define bind_2tp(K_, ptree_, tstr1_, t1_, v1_, \
- tstr2_, t2_, v2_) \
- TValue v1_, v2_; \
- if (!ttispair(ptree_) || !ttispair(kcdr(ptree_)) || \
- !ttisnil(kcddr(ptree_))) { \
- klispE_throw_simple(K_, "Bad ptree (expected two arguments)"); \
- return; \
- } \
- v1_ = kcar(ptree_); \
- v2_ = kcadr(ptree_); \
- if (!t1_(v1_)) { \
- klispE_throw_simple(K_, "Bad type on first argument (expected " \
- tstr1_ ")"); \
- return; \
- } else if (!t2_(v2_)) { \
- klispE_throw_simple(K_, "Bad type on second argument (expected " \
- tstr2_ ")"); \
- return; \
+ "any", anytype, (v2_))
+
+#define bind_2tp(K_, ptree_, tstr1_, t1_, v1_, \
+ tstr2_, t2_, v2_) \
+ TValue v1_, v2_; \
+ if (!ttispair(ptree_) || !ttispair(kcdr(ptree_)) || \
+ !ttisnil(kcddr(ptree_))) { \
+ klispE_throw_simple(K_, "Bad ptree (expected two arguments)"); \
+ return; \
+ } \
+ v1_ = kcar(ptree_); \
+ v2_ = kcadr(ptree_); \
+ if (!t1_(v1_)) { \
+ klispE_throw_simple(K_, "Bad type on first argument (expected " \
+ tstr1_ ")"); \
+ return; \
+ } else if (!t2_(v2_)) { \
+ klispE_throw_simple(K_, "Bad type on second argument (expected " \
+ tstr2_ ")"); \
+ return; \
}
-#define bind_3p(K_, ptree_, v1_, v2_, v3_) \
- bind_3tp(K_, ptree_, "any", anytype, v1_, \
- "any", anytype, v2_, "any", anytype, v3_)
-
-#define bind_3tp(K_, ptree_, tstr1_, t1_, v1_, \
- tstr2_, t2_, v2_, tstr3_, t3_, v3_) \
- TValue v1_, v2_, v3_; \
- if (!ttispair(ptree_) || !ttispair(kcdr(ptree_)) || \
- !ttispair(kcddr (ptree_)) || !ttisnil(kcdddr(ptree_))) { \
- klispE_throw_simple(K_, "Bad ptree (expected three arguments)"); \
- return; \
- } \
- v1_ = kcar(ptree_); \
- v2_ = kcadr(ptree_); \
- v3_ = kcaddr(ptree_); \
- if (!t1_(v1_)) { \
- klispE_throw_simple(K_, "Bad type on first argument (expected " \
- tstr1_ ")"); \
- return; \
- } else if (!t2_(v2_)) { \
- klispE_throw_simple(K_, "Bad type on second argument (expected " \
- tstr2_ ")"); \
- return; \
- } else if (!t3_(v3_)) { \
- klispE_throw_simple(K_, "Bad type on third argument (expected " \
- tstr3_ ")"); \
- return; \
+#define bind_3p(K_, ptree_, v1_, v2_, v3_) \
+ bind_3tp(K_, ptree_, "any", anytype, v1_, \
+ "any", anytype, v2_, "any", anytype, v3_)
+
+#define bind_3tp(K_, ptree_, tstr1_, t1_, v1_, \
+ tstr2_, t2_, v2_, tstr3_, t3_, v3_) \
+ TValue v1_, v2_, v3_; \
+ if (!ttispair(ptree_) || !ttispair(kcdr(ptree_)) || \
+ !ttispair(kcddr (ptree_)) || !ttisnil(kcdddr(ptree_))) { \
+ klispE_throw_simple(K_, "Bad ptree (expected three arguments)"); \
+ return; \
+ } \
+ v1_ = kcar(ptree_); \
+ v2_ = kcadr(ptree_); \
+ v3_ = kcaddr(ptree_); \
+ if (!t1_(v1_)) { \
+ klispE_throw_simple(K_, "Bad type on first argument (expected " \
+ tstr1_ ")"); \
+ return; \
+ } else if (!t2_(v2_)) { \
+ klispE_throw_simple(K_, "Bad type on second argument (expected " \
+ tstr2_ ")"); \
+ return; \
+ } else if (!t3_(v3_)) { \
+ klispE_throw_simple(K_, "Bad type on third argument (expected " \
+ tstr3_ ")"); \
+ return; \
}
/* bind at least 1 parameter, like (v1_ . v2_) */
-#define bind_al1p(K_, ptree_, v1_, v2_) \
+#define bind_al1p(K_, ptree_, v1_, v2_) \
bind_al1tp((K_), (ptree_), "any", anytype, (v1_), (v2_))
/* bind at least 1 parameters (with type), like (v1_ . v2_) */
-#define bind_al1tp(K_, ptree_, tstr1_, t1_, v1_, v2_) \
- TValue v1_, v2_; \
- if (!ttispair(ptree_)) { \
- klispE_throw_simple(K_, "Bad ptree (expected at least " \
- "one argument)"); \
- return; \
- } \
- v1_ = kcar(ptree_); \
- v2_ = kcdr(ptree_); \
- if (!t1_(v1_)) { \
- klispE_throw_simple(K_, "Bad type on first argument (expected " \
- tstr1_ ")"); \
- return; \
+#define bind_al1tp(K_, ptree_, tstr1_, t1_, v1_, v2_) \
+ TValue v1_, v2_; \
+ if (!ttispair(ptree_)) { \
+ klispE_throw_simple(K_, "Bad ptree (expected at least " \
+ "one argument)"); \
+ return; \
+ } \
+ v1_ = kcar(ptree_); \
+ v2_ = kcdr(ptree_); \
+ if (!t1_(v1_)) { \
+ klispE_throw_simple(K_, "Bad type on first argument (expected " \
+ tstr1_ ")"); \
+ return; \
}
/* bind at least 2 parameters, like (v1_ v2_ . v3_) */
-#define bind_al2p(K_, ptree_, v1_, v2_, v3_) \
+#define bind_al2p(K_, ptree_, v1_, v2_, v3_) \
bind_al2tp((K_), (ptree_), "any", anytype, (v1_), \
- "any", anytype, (v2_), (v3_))
+ "any", anytype, (v2_), (v3_))
/* bind at least 2 parameters (with type), like (v1_ v2_ . v3_) */
-#define bind_al2tp(K_, ptree_, tstr1_, t1_, v1_, \
- tstr2_, t2_, v2_, v3_) \
- TValue v1_, v2_, v3_; \
- if (!ttispair(ptree_) || !ttispair(kcdr(ptree_))) { \
- klispE_throw_simple(K_, "Bad ptree (expected at least " \
- "two arguments)"); \
- return; \
- } \
- v1_ = kcar(ptree_); \
- v2_ = kcadr(ptree_); \
- v3_ = kcddr(ptree_); \
- if (!t1_(v1_)) { \
- klispE_throw_simple(K_, "Bad type on first argument (expected " \
- tstr1_ ")"); \
- return; \
- } else if (!t2_(v2_)) { \
- klispE_throw_simple(K_, "Bad type on second argument (expected " \
- tstr2_ ")"); \
- return; \
+#define bind_al2tp(K_, ptree_, tstr1_, t1_, v1_, \
+ tstr2_, t2_, v2_, v3_) \
+ TValue v1_, v2_, v3_; \
+ if (!ttispair(ptree_) || !ttispair(kcdr(ptree_))) { \
+ klispE_throw_simple(K_, "Bad ptree (expected at least " \
+ "two arguments)"); \
+ return; \
+ } \
+ v1_ = kcar(ptree_); \
+ v2_ = kcadr(ptree_); \
+ v3_ = kcddr(ptree_); \
+ if (!t1_(v1_)) { \
+ klispE_throw_simple(K_, "Bad type on first argument (expected " \
+ tstr1_ ")"); \
+ return; \
+ } else if (!t2_(v2_)) { \
+ klispE_throw_simple(K_, "Bad type on second argument (expected " \
+ tstr2_ ")"); \
+ return; \
}
/* bind at least 3 parameters, like (v1_ v2_ v3_ . v4_) */
-#define bind_al3p(K_, ptree_, v1_, v2_, v3_, v4_) \
- bind_al3tp((K_), (ptree_), "any", anytype, (v1_), \
- "any", anytype, (v2_), "any", anytype, (v3_), (v4_)) \
+#define bind_al3p(K_, ptree_, v1_, v2_, v3_, v4_) \
+ bind_al3tp((K_), (ptree_), "any", anytype, (v1_), \
+ "any", anytype, (v2_), "any", anytype, (v3_), (v4_)) \
/* bind at least 3 parameters (with type), like (v1_ v2_ v3_ . v4_) */
-#define bind_al3tp(K_, ptree_, tstr1_, t1_, v1_, \
- tstr2_, t2_, v2_, tstr3_, t3_, v3_, v4_) \
- TValue v1_, v2_, v3_, v4_; \
- if (!ttispair(ptree_) || !ttispair(kcdr(ptree_)) || \
- !ttispair(kcddr(ptree_))) { \
- klispE_throw_simple(K_, "Bad ptree (expected at least " \
- "three arguments)"); \
- return; \
- } \
- v1_ = kcar(ptree_); \
- v2_ = kcadr(ptree_); \
- v3_ = kcaddr(ptree_); \
- v4_ = kcdddr(ptree_); \
- if (!t1_(v1_)) { \
- klispE_throw_simple(K_, "Bad type on first argument (expected " \
- tstr1_ ")"); \
- return; \
- } else if (!t2_(v2_)) { \
- klispE_throw_simple(K_, "Bad type on second argument (expected " \
- tstr2_ ")"); \
- return; \
- } else if (!t3_(v3_)) { \
- klispE_throw_simple(K_, "Bad type on third argument (expected " \
- tstr3_ ")"); \
- return; \
+#define bind_al3tp(K_, ptree_, tstr1_, t1_, v1_, \
+ tstr2_, t2_, v2_, tstr3_, t3_, v3_, v4_) \
+ TValue v1_, v2_, v3_, v4_; \
+ if (!ttispair(ptree_) || !ttispair(kcdr(ptree_)) || \
+ !ttispair(kcddr(ptree_))) { \
+ klispE_throw_simple(K_, "Bad ptree (expected at least " \
+ "three arguments)"); \
+ return; \
+ } \
+ v1_ = kcar(ptree_); \
+ v2_ = kcadr(ptree_); \
+ v3_ = kcaddr(ptree_); \
+ v4_ = kcdddr(ptree_); \
+ if (!t1_(v1_)) { \
+ klispE_throw_simple(K_, "Bad type on first argument (expected " \
+ tstr1_ ")"); \
+ return; \
+ } else if (!t2_(v2_)) { \
+ klispE_throw_simple(K_, "Bad type on second argument (expected " \
+ tstr2_ ")"); \
+ return; \
+ } else if (!t3_(v3_)) { \
+ klispE_throw_simple(K_, "Bad type on third argument (expected " \
+ tstr3_ ")"); \
+ return; \
}
@@ -275,24 +275,24 @@ inline bool knum_same_signp(klisp_State *K, TValue n1, TValue n2)
type type, and puts that element in par
returns false if par is nil
In any other case it throws an error */
-#define get_opt_tpar(K_, par_, tstr_, t_) ({ \
- bool res_; \
- if (ttisnil(par_)) { \
- res_ = false; \
- } else if (!ttispair(par_) || !ttisnil(kcdr(par_))) { \
- klispE_throw_simple((K_), \
- "Bad ptree structure " \
- "(in optional argument)"); \
- return; \
- } else if (!t_(kcar(par_))) { \
- klispE_throw_simple(K_, "Bad type on optional argument " \
- "(expected " tstr_ ")"); \
- return; \
- } else { \
- par_ = kcar(par_); \
- res_ = true; \
- } \
- res_; })
+#define get_opt_tpar(K_, par_, tstr_, t_) ({ \
+ bool res_; \
+ if (ttisnil(par_)) { \
+ res_ = false; \
+ } else if (!ttispair(par_) || !ttisnil(kcdr(par_))) { \
+ klispE_throw_simple((K_), \
+ "Bad ptree structure " \
+ "(in optional argument)"); \
+ return; \
+ } else if (!t_(kcar(par_))) { \
+ klispE_throw_simple(K_, "Bad type on optional argument " \
+ "(expected " tstr_ ")"); \
+ return; \
+ } else { \
+ par_ = kcar(par_); \
+ res_ = true; \
+ } \
+ res_; })
/*
** This states are useful for traversing trees, saving the state in the
@@ -311,8 +311,8 @@ inline void unmark_list(klisp_State *K, TValue obj)
{
UNUSED(K); /* not needed, it's here for consistency */
while(ttispair(obj) && kis_marked(obj)) {
- kunmark(obj);
- obj = kcdr(obj);
+ kunmark(obj);
+ obj = kcdr(obj);
}
}
@@ -323,13 +323,13 @@ inline void unmark_tree(klisp_State *K, TValue obj)
ks_spush(K, obj);
while(!ks_sisempty(K)) {
- obj = ks_spop(K);
+ obj = ks_spop(K);
- if (ttispair(obj) && kis_marked(obj)) {
- kunmark(obj);
- ks_spush(K, kcdr(obj));
- ks_spush(K, kcar(obj));
- } else if (ttisvector(obj) && kis_marked(obj)) {
+ if (ttispair(obj) && kis_marked(obj)) {
+ kunmark(obj);
+ ks_spush(K, kcdr(obj));
+ ks_spush(K, kcar(obj));
+ } else if (ttisvector(obj) && kis_marked(obj)) {
kunmark(obj);
uint32_t i = kvector_size(obj);
const TValue *array = kvector_buf(obj);
@@ -347,20 +347,20 @@ inline void unmark_tree(klisp_State *K, TValue obj)
KCHK_LS_FORCE_COPY, KCHK_ALLOW_CYCLE, KCHK_AVOID_ENCYCLE, etc) */
/* typed finite list. Structure error are thrown before type errors */
void check_typed_list(klisp_State *K, bool (*typep)(TValue), bool allow_infp,
- TValue obj, int32_t *pairs, int32_t *cpairs);
+ TValue obj, int32_t *pairs, int32_t *cpairs);
/* check that obj is a list, returns the number of pairs */
/* TODO change the return to void and add int32_t pairs obj */
void check_list(klisp_State *K, bool allow_infp, TValue obj,
- int32_t *pairs, int32_t *cpairs);
+ int32_t *pairs, int32_t *cpairs);
/* TODO: add unchecked_copy_list */
/* TODO: add check_copy_typed_list */
/* check that obj is a list and make a copy if it is not immutable or
- force_copy is true */
+ force_copy is true */
/* GC: assumes obj is rooted */
TValue check_copy_list(klisp_State *K, TValue obj, bool force_copy,
- int32_t *pairs, int32_t *cpairs);
+ int32_t *pairs, int32_t *cpairs);
/* check that obj is a list of environments and make a copy but don't keep
the cycles */
@@ -427,8 +427,8 @@ void do_set_pass(klisp_State *K);
/* dynamic var */
TValue make_bind_continuation(klisp_State *K, TValue key,
- TValue old_flag, TValue old_value,
- TValue new_flag, TValue new_value);
+ TValue old_flag, TValue old_value,
+ TValue new_flag, TValue new_value);
TValue check_copy_guards(klisp_State *K, char *name, TValue obj);
void guard_dynamic_extent(klisp_State *K);
@@ -442,10 +442,10 @@ inline int32_t kmax32(int32_t a, int32_t b) { return a > b? a : b; }
inline int32_t kcheck32(klisp_State *K, char *msg, int64_t i)
{
if (i > (int64_t) INT32_MAX || i < (int64_t) INT32_MIN) {
- klispE_throw_simple(K, msg);
- return 0;
+ klispE_throw_simple(K, msg);
+ return 0;
} else {
- return (int32_t) i;
+ return (int32_t) i;
}
}
@@ -468,7 +468,7 @@ int32_t ksmallest_index(klisp_State *K, TValue obj, TValue tk);
/* Helper for get-list-metrics, and list-tail, list-ref and list-set!
when receiving bigint indexes */
void get_list_metrics_aux(klisp_State *K, TValue obj, int32_t *p, int32_t *n,
- int32_t *a, int32_t *c);
+ int32_t *a, int32_t *c);
/* Helper for eq? and equal? */
bool eq2p(klisp_State *K, TValue obj1, TValue obj2);
@@ -497,7 +497,7 @@ void map_for_each_get_metrics(
of cdrs (replacing the value of lss) */
/* GC: Assumes lss is rooted */
TValue map_for_each_get_cars_cdrs(klisp_State *K, TValue *lss,
- int32_t apairs, int32_t cpairs);
+ int32_t apairs, int32_t cpairs);
/* Transpose lss so that the result is a list of lists, each one having
metrics (app_apairs, app_cpairs). The metrics of the returned list
@@ -505,8 +505,8 @@ TValue map_for_each_get_cars_cdrs(klisp_State *K, TValue *lss,
/* GC: Assumes lss is rooted */
TValue map_for_each_transpose(klisp_State *K, TValue lss,
- int32_t app_apairs, int32_t app_cpairs,
- int32_t res_apairs, int32_t res_cpairs);
+ int32_t app_apairs, int32_t app_cpairs,
+ int32_t res_apairs, int32_t res_cpairs);
/*
@@ -522,47 +522,47 @@ TValue map_for_each_transpose(klisp_State *K, TValue lss,
/* TODO add si to the symbols */
#if KTRACK_SI
-#define add_operative(K_, env_, n_, fn_, ...) \
- { symbol = ksymbol_new_b(K_, n_, KNIL); \
- value = kmake_operative(K_, fn_, __VA_ARGS__); \
- TValue str = kstring_new_b_imm(K_, __FILE__); \
- TValue si = kcons(K, str, kcons(K_, i2tv(__LINE__), \
- i2tv(0))); \
- kset_source_info(K_, value, si); \
- kadd_binding(K_, env_, symbol, value); }
+#define add_operative(K_, env_, n_, fn_, ...) \
+ { symbol = ksymbol_new_b(K_, n_, KNIL); \
+ value = kmake_operative(K_, fn_, __VA_ARGS__); \
+ TValue str = kstring_new_b_imm(K_, __FILE__); \
+ TValue si = kcons(K, str, kcons(K_, i2tv(__LINE__), \
+ i2tv(0))); \
+ kset_source_info(K_, value, si); \
+ kadd_binding(K_, env_, symbol, value); }
#define add_applicative(K_, env_, n_, fn_, ...) \
- { symbol = ksymbol_new_b(K_, n_, KNIL); \
- value = kmake_applicative(K_, fn_, __VA_ARGS__); \
- TValue str = kstring_new_b_imm(K_, __FILE__); \
- TValue si = kcons(K, str, kcons(K_, i2tv(__LINE__), \
- i2tv(0))); \
- kset_source_info(K_, kunwrap(value), si); \
- kset_source_info(K_, value, si); \
- kadd_binding(K_, env_, symbol, value); }
+ { symbol = ksymbol_new_b(K_, n_, KNIL); \
+ value = kmake_applicative(K_, fn_, __VA_ARGS__); \
+ TValue str = kstring_new_b_imm(K_, __FILE__); \
+ TValue si = kcons(K, str, kcons(K_, i2tv(__LINE__), \
+ i2tv(0))); \
+ kset_source_info(K_, kunwrap(value), si); \
+ kset_source_info(K_, value, si); \
+ kadd_binding(K_, env_, symbol, value); }
#else /* KTRACK_SI */
-#define add_operative(K_, env_, n_, fn_, ...) \
- { symbol = ksymbol_new_b(K_, n_, KNIL); \
- value = kmake_operative(K_, fn_, __VA_ARGS__); \
- kadd_binding(K_, env_, symbol, value); }
-
-#define add_applicative(K_, env_, n_, fn_, ...) \
- { symbol = ksymbol_new_b(K_, n_, KNIL); \
- value = kmake_applicative(K_, fn_, __VA_ARGS__); \
- kadd_binding(K_, env_, symbol, value); }
+#define add_operative(K_, env_, n_, fn_, ...) \
+ { symbol = ksymbol_new_b(K_, n_, KNIL); \
+ value = kmake_operative(K_, fn_, __VA_ARGS__); \
+ kadd_binding(K_, env_, symbol, value); }
+
+#define add_applicative(K_, env_, n_, fn_, ...) \
+ { symbol = ksymbol_new_b(K_, n_, KNIL); \
+ value = kmake_applicative(K_, fn_, __VA_ARGS__); \
+ kadd_binding(K_, env_, symbol, value); }
#endif /* KTRACK_SI */
-#define add_value(K_, env_, n_, v_) \
- { value = v_; \
- symbol = ksymbol_new_b(K_, n_, KNIL); \
- kadd_binding(K_, env_, symbol, v_); }
+#define add_value(K_, env_, n_, v_) \
+ { value = v_; \
+ symbol = ksymbol_new_b(K_, n_, KNIL); \
+ kadd_binding(K_, env_, symbol, v_); }
#endif
/* for initiliazing continuation names */
#define add_cont_name(K_, t_, c_, n_) \
- { TValue str = kstring_new_b_imm(K_, n_); \
- TValue *node = klispH_set(K_, t_, p2tv(c_)); \
- *node = str; \
+ { TValue str = kstring_new_b_imm(K_, n_); \
+ TValue *node = klispH_set(K_, t_, p2tv(c_)); \
+ *node = str; \
}
diff --git a/src/kgkd_vars.c b/src/kgkd_vars.c
@@ -64,5 +64,5 @@ void kinit_kgkd_vars_ground_env(klisp_State *K)
/* 10.1.1 make-keyed-dynamic-variable */
add_applicative(K, ground_env, "make-keyed-dynamic-variable",
- make_keyed_dynamic_variable, 0);
+ make_keyed_dynamic_variable, 0);
}
diff --git a/src/kgkeywords.c b/src/kgkeywords.c
@@ -93,7 +93,7 @@ void kinit_keywords_ground_env(klisp_State *K)
/* ?.? keyword? */
add_applicative(K, ground_env, "keyword?", typep, 2, symbol,
- i2tv(K_TKEYWORD));
+ i2tv(K_TKEYWORD));
/* ?.? keyword->string, string->keyword */
add_applicative(K, ground_env, "keyword->string", keyword_to_string, 0);
add_applicative(K, ground_env, "string->keyword", string_to_keyword, 0);
diff --git a/src/kgks_vars.c b/src/kgks_vars.c
@@ -53,7 +53,7 @@ void do_sv_bind(klisp_State *K)
** xparams[0]: static key
*/
bind_2tp(K, ptree, "any", anytype, obj,
- "environment", ttisenvironment, env);
+ "environment", ttisenvironment, env);
UNUSED(denv);
TValue key = xparams[0];
/* GC: all objs are rooted in ptree, or xparams */
@@ -95,5 +95,5 @@ void kinit_kgks_vars_ground_env(klisp_State *K)
/* 11.1.1 make-keyed-static-variable */
add_applicative(K, ground_env, "make-keyed-static-variable",
- make_keyed_static_variable, 0);
+ make_keyed_static_variable, 0);
}
diff --git a/src/kgnumbers.c b/src/kgnumbers.c
@@ -66,14 +66,14 @@ inline int32_t min_ttype(TValue obj1, TValue obj2)
}
/* helper to make both arguments inexact if one of them is,
- n1 & n2 should be variable names that may be overwritten */
+ n1 & n2 should be variable names that may be overwritten */
/* GC: There is no problem because for now all inexact are stack
allocated */
-#define kensure_same_exactness(K, n1, n2) \
+#define kensure_same_exactness(K, n1, n2) \
({if (ttisinexact(n1) || ttisinexact(n2)) { \
- n1 = kexact_to_inexact(K, n1); \
- n2 = kexact_to_inexact(K, n2); \
- }})
+ n1 = kexact_to_inexact(K, n1); \
+ n2 = kexact_to_inexact(K, n2); \
+ }})
/* ASK John: this isn't quite right I think. The problem is with implicit
@@ -98,35 +98,35 @@ bool knum_eqp(klisp_State *K, TValue n1, TValue n2)
switch(max_ttype(n1, n2)) {
case K_TFIXINT:
- return ivalue(n1) == ivalue(n2);
+ return ivalue(n1) == ivalue(n2);
case K_TBIGINT:
- if (min_ttype(n1, n2) != K_TBIGINT) {
- /* NOTE: no fixint is =? to a bigint */
- return false;
- } else {
- /* both are bigints */
- return kbigint_eqp(n1, n2);
- }
+ if (min_ttype(n1, n2) != K_TBIGINT) {
+ /* NOTE: no fixint is =? to a bigint */
+ return false;
+ } else {
+ /* both are bigints */
+ return kbigint_eqp(n1, n2);
+ }
case K_TBIGRAT:
- if (min_ttype(n1, n2) != K_TBIGRAT) {
- /* NOTE: no fixint or bigint is =? to a bigrat */
- return false;
- } else {
- /* both are bigints */
- return kbigrat_eqp(K, n1, n2);
- }
+ if (min_ttype(n1, n2) != K_TBIGRAT) {
+ /* NOTE: no fixint or bigint is =? to a bigrat */
+ return false;
+ } else {
+ /* both are bigints */
+ return kbigrat_eqp(K, n1, n2);
+ }
case K_TEINF:
- return (tv_equal(n1, n2));
+ return (tv_equal(n1, n2));
case K_TDOUBLE:
- return (tv_equal(n1, n2));
+ return (tv_equal(n1, n2));
case K_TIINF: /* if the other was exact it was converted already */
- return (tv_equal(n1, n2));
+ return (tv_equal(n1, n2));
case K_TRWNPV:
case K_TUNDEFINED: /* no primary value, should throw an error */
- /* TEMP: this was already contemplated in type predicate */
+ /* TEMP: this was already contemplated in type predicate */
default:
- klispE_throw_simple(K, "unsupported type");
- return false;
+ klispE_throw_simple(K, "unsupported type");
+ return false;
}
}
@@ -137,32 +137,32 @@ bool knum_ltp(klisp_State *K, TValue n1, TValue n2)
switch(max_ttype(n1, n2)) {
case K_TFIXINT:
- return ivalue(n1) < ivalue(n2);
+ return ivalue(n1) < ivalue(n2);
case K_TBIGINT: {
- kensure_bigint(n1);
- kensure_bigint(n2);
- return kbigint_ltp(n1, n2);
+ kensure_bigint(n1);
+ kensure_bigint(n2);
+ return kbigint_ltp(n1, n2);
}
case K_TBIGRAT: {
- kensure_bigrat(n1);
- kensure_bigrat(n2);
- return kbigrat_ltp(K, n1, n2);
+ kensure_bigrat(n1);
+ kensure_bigrat(n2);
+ return kbigrat_ltp(K, n1, n2);
}
case K_TDOUBLE: /* both must be double, all inferior types
- convert to either double or inexact infinity */
- return (dvalue(n1) < dvalue(n2));
+ convert to either double or inexact infinity */
+ return (dvalue(n1) < dvalue(n2));
case K_TEINF:
- return !tv_equal(n1, n2) && (tv_equal(n1, KEMINF) ||
- tv_equal(n2, KEPINF));
+ return !tv_equal(n1, n2) && (tv_equal(n1, KEMINF) ||
+ tv_equal(n2, KEPINF));
case K_TIINF: /* if the other was exact it was converted already */
- return !tv_equal(n1, n2) && (tv_equal(n1, KIMINF) ||
- tv_equal(n2, KIPINF));
+ return !tv_equal(n1, n2) && (tv_equal(n1, KIMINF) ||
+ tv_equal(n2, KIPINF));
case K_TRWNPV:
case K_TUNDEFINED: /* no primary value, should throw an error */
- /* TEMP: this was already contemplated in type predicate */
+ /* TEMP: this was already contemplated in type predicate */
default:
- klispE_throw_simple(K, "unsupported type");
- return false;
+ klispE_throw_simple(K, "unsupported type");
+ return false;
}
}
@@ -184,22 +184,22 @@ bool knum_gep(klisp_State *K, TValue n1, TValue n2)
** have a primary value
*/
/* may evaluate K & n more than once */
-#define arith_return(K, n) \
- ({ if (ttisnwnpv(n) && kcurr_strict_arithp(K)) { \
- klispE_throw_simple_with_irritants(K, "result has no " \
- "primary value", \
- 1, n); \
- return KINERT; \
- } else { return n;}})
+#define arith_return(K, n) \
+ ({ if (ttisnwnpv(n) && kcurr_strict_arithp(K)) { \
+ klispE_throw_simple_with_irritants(K, "result has no " \
+ "primary value", \
+ 1, n); \
+ return KINERT; \
+ } else { return n;}})
/* may evaluate K & n more than once */
-#define arith_kapply_cc(K, n) \
- ({ if (ttisnwnpv(n) && kcurr_strict_arithp(K)) { \
- klispE_throw_simple_with_irritants(K, "result has no " \
- "primary value", \
- 1, n); \
- return; \
- } else { kapply_cc(K, n); return;}})
+#define arith_kapply_cc(K, n) \
+ ({ if (ttisnwnpv(n) && kcurr_strict_arithp(K)) { \
+ klispE_throw_simple_with_irritants(K, "result has no " \
+ "primary value", \
+ 1, n); \
+ return; \
+ } else { kapply_cc(K, n); return;}})
@@ -214,68 +214,68 @@ TValue knum_plus(klisp_State *K, TValue n1, TValue n2)
TValue res; /* used for results with no primary value */
switch(max_ttype(n1, n2)) {
case K_TFIXINT: {
- int64_t res = (int64_t) ivalue(n1) + (int64_t) ivalue(n2);
- if (res >= (int64_t) INT32_MIN &&
- res <= (int64_t) INT32_MAX) {
- return i2tv((int32_t) res);
- } /* else fall through */
+ int64_t res = (int64_t) ivalue(n1) + (int64_t) ivalue(n2);
+ if (res >= (int64_t) INT32_MIN &&
+ res <= (int64_t) INT32_MAX) {
+ return i2tv((int32_t) res);
+ } /* else fall through */
}
case K_TBIGINT: {
- kensure_bigint(n1);
- kensure_bigint(n2);
- return kbigint_plus(K, n1, n2);
+ kensure_bigint(n1);
+ kensure_bigint(n2);
+ return kbigint_plus(K, n1, n2);
}
case K_TBIGRAT: {
- kensure_bigrat(n1);
- kensure_bigrat(n2);
- return kbigrat_plus(K, n1, n2);
+ kensure_bigrat(n1);
+ kensure_bigrat(n2);
+ return kbigrat_plus(K, n1, n2);
}
case K_TDOUBLE: {
- double res = dvalue(n1) + dvalue(n2);
- /* check under & overflow */
- if (kcurr_strict_arithp(K)) {
- if (res == 0 && dvalue(n1) != -dvalue(n2)) {
- klispE_throw_simple(K, "underflow");
- return KINERT;
- } else if (isinf(res)) {
- klispE_throw_simple(K, "overflow");
- return KINERT;
- }
- }
- /* correctly encapsulate infinities and -0.0 */
- return ktag_double(res);
+ double res = dvalue(n1) + dvalue(n2);
+ /* check under & overflow */
+ if (kcurr_strict_arithp(K)) {
+ if (res == 0 && dvalue(n1) != -dvalue(n2)) {
+ klispE_throw_simple(K, "underflow");
+ return KINERT;
+ } else if (isinf(res)) {
+ klispE_throw_simple(K, "overflow");
+ return KINERT;
+ }
+ }
+ /* correctly encapsulate infinities and -0.0 */
+ return ktag_double(res);
}
case K_TEINF:
- if (!ttiseinf(n1))
- return n2;
- else if (!ttiseinf(n2))
- return n1;
- if (tv_equal(n1, n2))
- return n1;
- else { /* no primary value; handle error at the end of function */
- res = KRWNPV;
- break;
- }
+ if (!ttiseinf(n1))
+ return n2;
+ else if (!ttiseinf(n2))
+ return n1;
+ if (tv_equal(n1, n2))
+ return n1;
+ else { /* no primary value; handle error at the end of function */
+ res = KRWNPV;
+ break;
+ }
case K_TIINF:
- if (!ttisiinf(n1))
- return n2;
- else if (!ttisiinf(n2))
- return n1;
- if (tv_equal(n1, n2))
- return n1;
- else { /* no primary value; handle error at the end of function */
- res = KRWNPV;
- break;
- }
+ if (!ttisiinf(n1))
+ return n2;
+ else if (!ttisiinf(n2))
+ return n1;
+ if (tv_equal(n1, n2))
+ return n1;
+ else { /* no primary value; handle error at the end of function */
+ res = KRWNPV;
+ break;
+ }
case K_TRWNPV: /* no primary value */
- res = KRWNPV;
- break;
+ res = KRWNPV;
+ break;
case K_TUNDEFINED: /* undefined */
- res = KUNDEF;
- break;
+ res = KUNDEF;
+ break;
default:
- klispE_throw_simple(K, "unsupported type");
- return KINERT;
+ klispE_throw_simple(K, "unsupported type");
+ return KINERT;
}
/* check for no primary value and value of strict arith */
@@ -290,68 +290,68 @@ TValue knum_times(klisp_State *K, TValue n1, TValue n2)
TValue res; /* used for results with no primary value */
switch(max_ttype(n1, n2)) {
case K_TFIXINT: {
- int64_t res = (int64_t) ivalue(n1) * (int64_t) ivalue(n2);
- if (res >= (int64_t) INT32_MIN &&
- res <= (int64_t) INT32_MAX) {
- return i2tv((int32_t) res);
- } /* else fall through */
+ int64_t res = (int64_t) ivalue(n1) * (int64_t) ivalue(n2);
+ if (res >= (int64_t) INT32_MIN &&
+ res <= (int64_t) INT32_MAX) {
+ return i2tv((int32_t) res);
+ } /* else fall through */
}
case K_TBIGINT: {
- kensure_bigint(n1);
- kensure_bigint(n2);
- return kbigint_times(K, n1, n2);
+ kensure_bigint(n1);
+ kensure_bigint(n2);
+ return kbigint_times(K, n1, n2);
}
case K_TBIGRAT: {
- kensure_bigrat(n1);
- kensure_bigrat(n2);
- return kbigrat_times(K, n1, n2);
+ kensure_bigrat(n1);
+ kensure_bigrat(n2);
+ return kbigrat_times(K, n1, n2);
}
case K_TDOUBLE: {
- double res = dvalue(n1) * dvalue(n2);
- /* check under & overflow */
- if (kcurr_strict_arithp(K)) {
- if (res == 0 && dvalue(n1) != 0.0 && dvalue(n2) != 0.00) {
- klispE_throw_simple(K, "underflow");
- return KINERT;
- } else if (isinf(res)) {
- klispE_throw_simple(K, "overflow");
- return KINERT;
- }
- }
- /* correctly encapsulate infinities and -0.0 */
- return ktag_double(res);
+ double res = dvalue(n1) * dvalue(n2);
+ /* check under & overflow */
+ if (kcurr_strict_arithp(K)) {
+ if (res == 0 && dvalue(n1) != 0.0 && dvalue(n2) != 0.00) {
+ klispE_throw_simple(K, "underflow");
+ return KINERT;
+ } else if (isinf(res)) {
+ klispE_throw_simple(K, "overflow");
+ return KINERT;
+ }
+ }
+ /* correctly encapsulate infinities and -0.0 */
+ return ktag_double(res);
}
case K_TEINF:
- if (!ttiseinf(n1) || !ttiseinf(n2)) {
- if (kfast_zerop(n1) || kfast_zerop(n2)) {
- /* report: #e+infinity * 0 has no primary value */
- res = KRWNPV;
- break;
- } else if (ttisexact(n1) && ttisexact(n2))
- return knum_same_signp(K, n1, n2)? KEPINF : KEMINF;
- else
- return knum_same_signp(K, n1, n2)? KIPINF : KIMINF;
- } else
- return (tv_equal(n1, n2))? KEPINF : KEMINF;
+ if (!ttiseinf(n1) || !ttiseinf(n2)) {
+ if (kfast_zerop(n1) || kfast_zerop(n2)) {
+ /* report: #e+infinity * 0 has no primary value */
+ res = KRWNPV;
+ break;
+ } else if (ttisexact(n1) && ttisexact(n2))
+ return knum_same_signp(K, n1, n2)? KEPINF : KEMINF;
+ else
+ return knum_same_signp(K, n1, n2)? KIPINF : KIMINF;
+ } else
+ return (tv_equal(n1, n2))? KEPINF : KEMINF;
case K_TIINF:
- if (!ttisiinf(n1) || !ttisiinf(n2)) {
- if (kfast_zerop(n1) || kfast_zerop(n2)) {
- /* report: #i[+-]infinity * 0 has no primary value */
- res = KRWNPV;
- break;
- } else
- return knum_same_signp(K, n1, n2)? KIPINF : KIMINF;
- } else
- return (tv_equal(n1, n2))? KIPINF : KIMINF;
+ if (!ttisiinf(n1) || !ttisiinf(n2)) {
+ if (kfast_zerop(n1) || kfast_zerop(n2)) {
+ /* report: #i[+-]infinity * 0 has no primary value */
+ res = KRWNPV;
+ break;
+ } else
+ return knum_same_signp(K, n1, n2)? KIPINF : KIMINF;
+ } else
+ return (tv_equal(n1, n2))? KIPINF : KIMINF;
case K_TRWNPV:
- res = KRWNPV;
- break;
+ res = KRWNPV;
+ break;
case K_TUNDEFINED:
- res = KUNDEF;
- break;
+ res = KUNDEF;
+ break;
default:
- klispE_throw_simple(K, "unsupported type");
- return KINERT;
+ klispE_throw_simple(K, "unsupported type");
+ return KINERT;
}
/* check for no primary value and value of strict arith */
@@ -367,69 +367,69 @@ TValue knum_minus(klisp_State *K, TValue n1, TValue n2)
switch(max_ttype(n1, n2)) {
case K_TFIXINT: {
- int64_t res = (int64_t) ivalue(n1) - (int64_t) ivalue(n2);
- if (res >= (int64_t) INT32_MIN &&
- res <= (int64_t) INT32_MAX) {
- return i2tv((int32_t) res);
- } /* else fall through */
+ int64_t res = (int64_t) ivalue(n1) - (int64_t) ivalue(n2);
+ if (res >= (int64_t) INT32_MIN &&
+ res <= (int64_t) INT32_MAX) {
+ return i2tv((int32_t) res);
+ } /* else fall through */
}
case K_TBIGINT: {
- kensure_bigint(n1);
- kensure_bigint(n2);
- return kbigint_minus(K, n1, n2);
+ kensure_bigint(n1);
+ kensure_bigint(n2);
+ return kbigint_minus(K, n1, n2);
}
case K_TBIGRAT: {
- kensure_bigrat(n1);
- kensure_bigrat(n2);
- return kbigrat_minus(K, n1, n2);
+ kensure_bigrat(n1);
+ kensure_bigrat(n2);
+ return kbigrat_minus(K, n1, n2);
}
case K_TDOUBLE: {
- /* both are double */
- double res = dvalue(n1) - dvalue(n2);
- /* check under & overflow */
- if (kcurr_strict_arithp(K)) {
- if (res == 0 && dvalue(n1) != dvalue(n2)) {
- klispE_throw_simple(K, "underflow");
- return KINERT;
- } else if (isinf(res)) {
- klispE_throw_simple(K, "overflow");
- return KINERT;
- }
- }
- /* correctly encapsulate infinities and -0.0 */
- return ktag_double(res);
+ /* both are double */
+ double res = dvalue(n1) - dvalue(n2);
+ /* check under & overflow */
+ if (kcurr_strict_arithp(K)) {
+ if (res == 0 && dvalue(n1) != dvalue(n2)) {
+ klispE_throw_simple(K, "underflow");
+ return KINERT;
+ } else if (isinf(res)) {
+ klispE_throw_simple(K, "overflow");
+ return KINERT;
+ }
+ }
+ /* correctly encapsulate infinities and -0.0 */
+ return ktag_double(res);
}
case K_TEINF:
- if (!ttiseinf(n1))
- return kneg_inf(n2);
- else if (!ttiseinf(n2))
- return n1;
- if (tv_equal(n1, n2)) {
- /* no primary value; handle error at the end of function */
- res = KRWNPV;
- break;
- } else
- return n1;
+ if (!ttiseinf(n1))
+ return kneg_inf(n2);
+ else if (!ttiseinf(n2))
+ return n1;
+ if (tv_equal(n1, n2)) {
+ /* no primary value; handle error at the end of function */
+ res = KRWNPV;
+ break;
+ } else
+ return n1;
case K_TIINF:
- if (!ttisiinf(n1))
- return kneg_inf(n2);
- else if (!ttisiinf(n2))
- return n1;
- if (tv_equal(n1, n2)) {
- /* no primary value; handle error at the end of function */
- res = KRWNPV;
- break;
- } else
- return n1;
+ if (!ttisiinf(n1))
+ return kneg_inf(n2);
+ else if (!ttisiinf(n2))
+ return n1;
+ if (tv_equal(n1, n2)) {
+ /* no primary value; handle error at the end of function */
+ res = KRWNPV;
+ break;
+ } else
+ return n1;
case K_TRWNPV: /* no primary value */
- res = KRWNPV;
- break;
+ res = KRWNPV;
+ break;
case K_TUNDEFINED: /* undefined */
- res = KUNDEF;
- break;
+ res = KUNDEF;
+ break;
default:
- klispE_throw_simple(K, "unsupported type");
- return KINERT;
+ klispE_throw_simple(K, "unsupported type");
+ return KINERT;
}
/* check for no primary value and value of strict arith */
@@ -445,69 +445,69 @@ TValue knum_divided(klisp_State *K, TValue n1, TValue n2)
/* first check the most common error, division by zero */
if (kfast_zerop(n2)) {
- klispE_throw_simple(K, "division by zero");
- return KINERT;
+ klispE_throw_simple(K, "division by zero");
+ return KINERT;
}
switch(max_ttype(n1, n2)) {
case K_TFIXINT: {
- int64_t res = (int64_t) ivalue(n1) / (int64_t) ivalue(n2);
- int64_t rem = (int64_t) ivalue(n1) % (int64_t) ivalue(n2);
- if (rem == 0 && res >= (int64_t) INT32_MIN &&
- res <= (int64_t) INT32_MAX) {
- return i2tv((int32_t) res);
- } /* else fall through */
+ int64_t res = (int64_t) ivalue(n1) / (int64_t) ivalue(n2);
+ int64_t rem = (int64_t) ivalue(n1) % (int64_t) ivalue(n2);
+ if (rem == 0 && res >= (int64_t) INT32_MIN &&
+ res <= (int64_t) INT32_MAX) {
+ return i2tv((int32_t) res);
+ } /* else fall through */
}
case K_TBIGINT: /* just handle it as a rational */
case K_TBIGRAT: {
- kensure_bigrat(n1);
- kensure_bigrat(n2);
- return kbigrat_divided(K, n1, n2);
+ kensure_bigrat(n1);
+ kensure_bigrat(n2);
+ return kbigrat_divided(K, n1, n2);
}
case K_TDOUBLE: {
- double res = dvalue(n1) / dvalue(n2);
- /* check under & overflow */
- if (kcurr_strict_arithp(K)) {
- if (res == 0 && dvalue(n1) != 0.0) {
- klispE_throw_simple(K, "underflow");
- return KINERT;
- } else if (isinf(res)) {
- klispE_throw_simple(K, "overflow");
- return KINERT;
- }
- }
- /* correctly encapsulate infinities and -0.0 */
- return ktag_double(res);
+ double res = dvalue(n1) / dvalue(n2);
+ /* check under & overflow */
+ if (kcurr_strict_arithp(K)) {
+ if (res == 0 && dvalue(n1) != 0.0) {
+ klispE_throw_simple(K, "underflow");
+ return KINERT;
+ } else if (isinf(res)) {
+ klispE_throw_simple(K, "overflow");
+ return KINERT;
+ }
+ }
+ /* correctly encapsulate infinities and -0.0 */
+ return ktag_double(res);
}
case K_TEINF: {
- if (ttiseinf(n1) && ttiseinf(n2)) {
- klispE_throw_simple(K, "infinity divided by infinity");
- return KINERT;
- } else if (ttiseinf(n1)) {
- return knum_same_signp(K, n1, n2)? KEPINF : KEMINF;
- } else { /* ttiseinf(n2) */
- return i2tv(0);
- }
+ if (ttiseinf(n1) && ttiseinf(n2)) {
+ klispE_throw_simple(K, "infinity divided by infinity");
+ return KINERT;
+ } else if (ttiseinf(n1)) {
+ return knum_same_signp(K, n1, n2)? KEPINF : KEMINF;
+ } else { /* ttiseinf(n2) */
+ return i2tv(0);
+ }
}
case K_TIINF:
- if (ttisiinf(n1) && ttisiinf(n2)) {
- klispE_throw_simple(K, "infinity divided by infinity");
- return KINERT;
- } else if (ttisiinf(n1)) {
- return knum_same_signp(K, n1, n2)? KIPINF : KIMINF;
- } else { /* ttiseinf(n2) */
- /* NOTE: I guess this doens't count as underflow */
- return d2tv(0.0);
- }
+ if (ttisiinf(n1) && ttisiinf(n2)) {
+ klispE_throw_simple(K, "infinity divided by infinity");
+ return KINERT;
+ } else if (ttisiinf(n1)) {
+ return knum_same_signp(K, n1, n2)? KIPINF : KIMINF;
+ } else { /* ttiseinf(n2) */
+ /* NOTE: I guess this doens't count as underflow */
+ return d2tv(0.0);
+ }
case K_TRWNPV:
- res = KRWNPV;
- break;
+ res = KRWNPV;
+ break;
case K_TUNDEFINED:
- res = KUNDEF;
- break;
+ res = KUNDEF;
+ break;
default:
- klispE_throw_simple(K, "unsupported type");
- return KINERT;
+ klispE_throw_simple(K, "unsupported type");
+ return KINERT;
}
/* check for no primary value and value of strict arith */
@@ -519,37 +519,37 @@ TValue knum_abs(klisp_State *K, TValue n)
{
switch(ttype(n)) {
case K_TFIXINT: {
- int32_t i = ivalue(n);
- if (i != INT32_MIN)
- return (i < 0? i2tv(-i) : n);
- /* if i == INT32_MIN, fall through */
- /* MAYBE: we could cache the bigint INT32_MAX+1 */
- /* else fall through */
+ int32_t i = ivalue(n);
+ if (i != INT32_MIN)
+ return (i < 0? i2tv(-i) : n);
+ /* if i == INT32_MIN, fall through */
+ /* MAYBE: we could cache the bigint INT32_MAX+1 */
+ /* else fall through */
}
case K_TBIGINT: {
- /* this is needed for INT32_MIN, can't be in previous
- case because it should be in the same block, remember
- the bigint is allocated on the stack. */
- kensure_bigint(n);
- return kbigint_abs(K, n);
+ /* this is needed for INT32_MIN, can't be in previous
+ case because it should be in the same block, remember
+ the bigint is allocated on the stack. */
+ kensure_bigint(n);
+ return kbigint_abs(K, n);
}
case K_TBIGRAT: {
- return kbigrat_abs(K, n);
+ return kbigrat_abs(K, n);
}
case K_TDOUBLE: {
- return ktag_double(fabs(dvalue(n)));
+ return ktag_double(fabs(dvalue(n)));
}
case K_TEINF:
- return KEPINF;
+ return KEPINF;
case K_TIINF:
- return KIPINF;
+ return KIPINF;
case K_TRWNPV:
- /* ASK John: is the error here okay */
- arith_return(K, KRWNPV);
+ /* ASK John: is the error here okay */
+ arith_return(K, KRWNPV);
default:
- /* shouldn't happen */
- klispE_throw_simple(K, "unsupported type");
- return KINERT;
+ /* shouldn't happen */
+ klispE_throw_simple(K, "unsupported type");
+ return KINERT;
}
}
@@ -564,48 +564,48 @@ TValue knum_gcd(klisp_State *K, TValue n1, TValue n2)
switch(max_ttype(n1, n2)) {
case K_TFIXINT: {
- int64_t gcd = kgcd32_64(ivalue(n1), ivalue(n2));
+ int64_t gcd = kgcd32_64(ivalue(n1), ivalue(n2));
/* May fail for gcd(INT32_MIN, INT32_MIN) because
- it would return INT32_MAX+1 */
- if (kfit_int32_t(gcd))
- return i2tv((int32_t) gcd);
- /* else fall through */
+ it would return INT32_MAX+1 */
+ if (kfit_int32_t(gcd))
+ return i2tv((int32_t) gcd);
+ /* else fall through */
}
case K_TBIGINT: {
- kensure_bigint(n1);
- kensure_bigint(n2);
- return kbigint_gcd(K, n1, n2);
+ kensure_bigint(n1);
+ kensure_bigint(n2);
+ return kbigint_gcd(K, n1, n2);
}
case K_TDOUBLE: {
- krooted_vars_push(K, &n1);
- krooted_vars_push(K, &n2);
- n1 = kinexact_to_exact(K, n1);
- n2 = kinexact_to_exact(K, n2);
- TValue res = knum_gcd(K, n1, n2);
- krooted_tvs_push(K, res);
- res = kexact_to_inexact(K, res);
- krooted_tvs_pop(K);
- krooted_vars_pop(K);
- krooted_vars_pop(K);
- return res;
+ krooted_vars_push(K, &n1);
+ krooted_vars_push(K, &n2);
+ n1 = kinexact_to_exact(K, n1);
+ n2 = kinexact_to_exact(K, n2);
+ TValue res = knum_gcd(K, n1, n2);
+ krooted_tvs_push(K, res);
+ res = kexact_to_inexact(K, res);
+ krooted_tvs_pop(K);
+ krooted_vars_pop(K);
+ krooted_vars_pop(K);
+ return res;
}
case K_TEINF:
- if (kfast_zerop(n2) || !ttiseinf(n1))
- return knum_abs(K, n1);
- else if (kfast_zerop(n1) || !ttiseinf(n2))
- return knum_abs(K, n2);
- else
- return KEPINF;
+ if (kfast_zerop(n2) || !ttiseinf(n1))
+ return knum_abs(K, n1);
+ else if (kfast_zerop(n1) || !ttiseinf(n2))
+ return knum_abs(K, n2);
+ else
+ return KEPINF;
case K_TIINF:
- if (kfast_zerop(n2) || !ttisiinf(n1))
- return knum_abs(K, n1);
- else if (kfast_zerop(n1) || !ttisiinf(n2))
- return knum_abs(K, n2);
- else
- return KIPINF;
+ if (kfast_zerop(n2) || !ttisiinf(n1))
+ return knum_abs(K, n1);
+ else if (kfast_zerop(n1) || !ttisiinf(n2))
+ return knum_abs(K, n2);
+ else
+ return KIPINF;
default:
- klispE_throw_simple(K, "unsupported type");
- return KINERT;
+ klispE_throw_simple(K, "unsupported type");
+ return KINERT;
}
}
@@ -619,43 +619,43 @@ TValue knum_lcm(klisp_State *K, TValue n1, TValue n2)
/* get this out of the way first */
if (kfast_zerop(n1) || kfast_zerop(n2)) {
- arith_return(K, KRWNPV);
+ arith_return(K, KRWNPV);
}
switch(max_ttype(n1, n2)) {
case K_TFIXINT: {
- int64_t lcm = klcm32_64(ivalue(n1), ivalue(n2));
- /* May fail for lcm(INT32_MIN, 1) because
- it would return INT32_MAX+1 */
- if (kfit_int32_t(lcm))
- return i2tv((int32_t) lcm);
- /* else fall through */
+ int64_t lcm = klcm32_64(ivalue(n1), ivalue(n2));
+ /* May fail for lcm(INT32_MIN, 1) because
+ it would return INT32_MAX+1 */
+ if (kfit_int32_t(lcm))
+ return i2tv((int32_t) lcm);
+ /* else fall through */
}
case K_TBIGINT: {
- kensure_bigint(n1);
- kensure_bigint(n2);
- return kbigint_lcm(K, n1, n2);
+ kensure_bigint(n1);
+ kensure_bigint(n2);
+ return kbigint_lcm(K, n1, n2);
}
case K_TDOUBLE: {
- krooted_vars_push(K, &n1);
- krooted_vars_push(K, &n2);
- n1 = kinexact_to_exact(K, n1);
- n2 = kinexact_to_exact(K, n2);
- TValue res = knum_lcm(K, n1, n2);
- krooted_tvs_push(K, res);
- res = kexact_to_inexact(K, res);
- krooted_tvs_pop(K);
- krooted_vars_pop(K);
- krooted_vars_pop(K);
- return res;
+ krooted_vars_push(K, &n1);
+ krooted_vars_push(K, &n2);
+ n1 = kinexact_to_exact(K, n1);
+ n2 = kinexact_to_exact(K, n2);
+ TValue res = knum_lcm(K, n1, n2);
+ krooted_tvs_push(K, res);
+ res = kexact_to_inexact(K, res);
+ krooted_tvs_pop(K);
+ krooted_vars_pop(K);
+ krooted_vars_pop(K);
+ return res;
}
case K_TEINF:
- return KEPINF;
+ return KEPINF;
case K_TIINF:
- return KIPINF;
+ return KIPINF;
default:
- klispE_throw_simple(K, "unsupported type");
- return KINERT;
+ klispE_throw_simple(K, "unsupported type");
+ return KINERT;
}
}
@@ -665,21 +665,21 @@ TValue knum_numerator(klisp_State *K, TValue n)
switch(ttype(n)) {
case K_TFIXINT:
case K_TBIGINT:
- return n;
+ return n;
case K_TBIGRAT:
- return kbigrat_numerator(K, n);
+ return kbigrat_numerator(K, n);
case K_TDOUBLE: {
- TValue res = kinexact_to_exact(K, n);
- krooted_vars_push(K, &res);
- res = knum_numerator(K, res);
- res = kexact_to_inexact(K, res);
- krooted_vars_pop(K);
- return res;
+ TValue res = kinexact_to_exact(K, n);
+ krooted_vars_push(K, &res);
+ res = knum_numerator(K, res);
+ res = kexact_to_inexact(K, res);
+ krooted_vars_pop(K);
+ return res;
}
/* case K_TEINF: infinities are not rational! */
default:
- klispE_throw_simple(K, "unsupported type");
- return KINERT;
+ klispE_throw_simple(K, "unsupported type");
+ return KINERT;
}
}
@@ -689,21 +689,21 @@ TValue knum_denominator(klisp_State *K, TValue n)
switch(ttype(n)) {
case K_TFIXINT:
case K_TBIGINT:
- return i2tv(1); /* denominator of integer is always (+)1 */
+ return i2tv(1); /* denominator of integer is always (+)1 */
case K_TBIGRAT:
- return kbigrat_denominator(K, n);
+ return kbigrat_denominator(K, n);
case K_TDOUBLE: {
- TValue res = kinexact_to_exact(K, n);
- krooted_vars_push(K, &res);
- res = knum_denominator(K, res);
- res = kexact_to_inexact(K, res);
- krooted_vars_pop(K);
- return res;
+ TValue res = kinexact_to_exact(K, n);
+ krooted_vars_push(K, &res);
+ res = knum_denominator(K, res);
+ res = kexact_to_inexact(K, res);
+ krooted_vars_pop(K);
+ return res;
}
/* case K_TEINF: infinities are not rational! */
default:
- klispE_throw_simple(K, "unsupported type");
- return KINERT;
+ klispE_throw_simple(K, "unsupported type");
+ return KINERT;
}
}
@@ -713,24 +713,24 @@ TValue knum_real_to_integer(klisp_State *K, TValue n, kround_mode mode)
switch(ttype(n)) {
case K_TFIXINT:
case K_TBIGINT:
- return n; /* integers are easy */
+ return n; /* integers are easy */
case K_TBIGRAT:
- return kbigrat_to_integer(K, n, mode);
+ return kbigrat_to_integer(K, n, mode);
case K_TDOUBLE:
- return kdouble_to_integer(K, n, mode);
+ return kdouble_to_integer(K, n, mode);
case K_TEINF:
- klispE_throw_simple(K, "infinite value");
- return KINERT;
+ klispE_throw_simple(K, "infinite value");
+ return KINERT;
case K_TIINF:
- klispE_throw_simple(K, "infinite value");
- return KINERT;
+ klispE_throw_simple(K, "infinite value");
+ return KINERT;
case K_TRWNPV:
- arith_return(K, KRWNPV);
+ arith_return(K, KRWNPV);
case K_TUNDEFINED:
- /* undefined in not a real, shouldn't get here, fall through */
+ /* undefined in not a real, shouldn't get here, fall through */
default:
- klispE_throw_simple(K, "unsupported type");
- return KINERT;
+ klispE_throw_simple(K, "unsupported type");
+ return KINERT;
}
}
@@ -742,8 +742,8 @@ TValue knum_simplest_rational(klisp_State *K, TValue n1, TValue n2)
/* first check that case that n1 > n2 */
if (knum_gtp(K, n1, n2)) {
- klispE_throw_simple(K, "x0 doesn't exists (n1 > n2)");
- return KINERT;
+ klispE_throw_simple(K, "x0 doesn't exists (n1 > n2)");
+ return KINERT;
}
/* we know that n1 <= n2 */
@@ -751,68 +751,68 @@ TValue knum_simplest_rational(klisp_State *K, TValue n1, TValue n2)
case K_TFIXINT:
case K_TBIGINT: /* for now do all with bigrat */
case K_TBIGRAT: {
- /* we know that n1 <= n2 */
- kensure_bigrat(n1);
- kensure_bigrat(n2);
- return kbigrat_simplest_rational(K, n1, n2);
+ /* we know that n1 <= n2 */
+ kensure_bigrat(n1);
+ kensure_bigrat(n2);
+ return kbigrat_simplest_rational(K, n1, n2);
}
case K_TDOUBLE: {
- /* both are double, for now just convert to rational */
- krooted_vars_push(K, &n1);
- krooted_vars_push(K, &n2);
- n1 = kinexact_to_exact(K, n1);
- n2 = kinexact_to_exact(K, n2);
- TValue res = knum_simplest_rational(K, n1, n2);
- krooted_tvs_push(K, res);
- res = kexact_to_inexact(K, res);
- krooted_tvs_pop(K);
- krooted_vars_pop(K);
- krooted_vars_pop(K);
- return res;
+ /* both are double, for now just convert to rational */
+ krooted_vars_push(K, &n1);
+ krooted_vars_push(K, &n2);
+ n1 = kinexact_to_exact(K, n1);
+ n2 = kinexact_to_exact(K, n2);
+ TValue res = knum_simplest_rational(K, n1, n2);
+ krooted_tvs_push(K, res);
+ res = kexact_to_inexact(K, res);
+ krooted_tvs_pop(K);
+ krooted_vars_pop(K);
+ krooted_vars_pop(K);
+ return res;
}
case K_TEINF:
- /* we know that n1 <= n2 */
- if (tv_equal(n1, n2)) {
- klispE_throw_simple(K, "x0 doesn't exists (n1 == n2 & "
- "irrational)");
- return KINERT;
- } else if (knegativep(n1) && kpositivep(n2)) {
- return i2tv(0);
- } else if (knegativep(n1)) {
- /* n1 -inf, n2 finite negative */
- /* ASK John: is this behaviour for infinities ok? */
- /* Also in the report example both 1/3 & 1/2 are simpler than
- 2/5... */
- return knum_real_to_integer(K, n2, K_FLOOR);
- } else {
- /* n1 finite positive, n2 +inf */
- /* ASK John: is this behaviour for infinities ok? */
- return knum_real_to_integer(K, n1, K_CEILING);
- }
+ /* we know that n1 <= n2 */
+ if (tv_equal(n1, n2)) {
+ klispE_throw_simple(K, "x0 doesn't exists (n1 == n2 & "
+ "irrational)");
+ return KINERT;
+ } else if (knegativep(n1) && kpositivep(n2)) {
+ return i2tv(0);
+ } else if (knegativep(n1)) {
+ /* n1 -inf, n2 finite negative */
+ /* ASK John: is this behaviour for infinities ok? */
+ /* Also in the report example both 1/3 & 1/2 are simpler than
+ 2/5... */
+ return knum_real_to_integer(K, n2, K_FLOOR);
+ } else {
+ /* n1 finite positive, n2 +inf */
+ /* ASK John: is this behaviour for infinities ok? */
+ return knum_real_to_integer(K, n1, K_CEILING);
+ }
case K_TIINF:
- /* we know that n1 <= n2 */
- if (tv_equal(n1, n2)) {
- klispE_throw_simple(K, "result with no primary value");
- return KINERT;
- } else if (knegativep(n1) && kpositivep(n2)) {
- return d2tv(0.0);
- } else if (knegativep(n1)) {
- /* n1 -inf, n2 finite negative */
- /* ASK John: is this behaviour for infinities ok? */
- /* Also in the report example both 1/3 & 1/2 are simpler than
- 2/5... */
- return knum_real_to_integer(K, n2, K_FLOOR);
- } else {
- /* n1 finite positive, n2 +inf */
- /* ASK John: is this behaviour for infinities ok? */
- return knum_real_to_integer(K, n1, K_CEILING);
- }
+ /* we know that n1 <= n2 */
+ if (tv_equal(n1, n2)) {
+ klispE_throw_simple(K, "result with no primary value");
+ return KINERT;
+ } else if (knegativep(n1) && kpositivep(n2)) {
+ return d2tv(0.0);
+ } else if (knegativep(n1)) {
+ /* n1 -inf, n2 finite negative */
+ /* ASK John: is this behaviour for infinities ok? */
+ /* Also in the report example both 1/3 & 1/2 are simpler than
+ 2/5... */
+ return knum_real_to_integer(K, n2, K_FLOOR);
+ } else {
+ /* n1 finite positive, n2 +inf */
+ /* ASK John: is this behaviour for infinities ok? */
+ return knum_real_to_integer(K, n1, K_CEILING);
+ }
case K_TRWNPV:
- arith_return(K, KRWNPV);
- /* complex and undefined should be captured by type predicate */
+ arith_return(K, KRWNPV);
+ /* complex and undefined should be captured by type predicate */
default:
- klispE_throw_simple(K, "unsupported type");
- return KINERT;
+ klispE_throw_simple(K, "unsupported type");
+ return KINERT;
}
}
@@ -826,44 +826,44 @@ TValue knum_rationalize(klisp_State *K, TValue n1, TValue n2)
case K_TFIXINT:
case K_TBIGINT: /* for now do all with bigrat */
case K_TBIGRAT: {
- /* we know that n1 <= n2 */
- kensure_bigrat(n1);
- kensure_bigrat(n2);
- return kbigrat_rationalize(K, n1, n2);
+ /* we know that n1 <= n2 */
+ kensure_bigrat(n1);
+ kensure_bigrat(n2);
+ return kbigrat_rationalize(K, n1, n2);
}
case K_TDOUBLE: {
- /* both are double, for now just convert to rational */
- krooted_vars_push(K, &n1);
- krooted_vars_push(K, &n2);
- n1 = kinexact_to_exact(K, n1);
- n2 = kinexact_to_exact(K, n2);
- TValue res = knum_rationalize(K, n1, n2);
- krooted_tvs_push(K, res);
- res = kexact_to_inexact(K, res);
- krooted_tvs_pop(K);
- krooted_vars_pop(K);
- krooted_vars_pop(K);
- return res;
+ /* both are double, for now just convert to rational */
+ krooted_vars_push(K, &n1);
+ krooted_vars_push(K, &n2);
+ n1 = kinexact_to_exact(K, n1);
+ n2 = kinexact_to_exact(K, n2);
+ TValue res = knum_rationalize(K, n1, n2);
+ krooted_tvs_push(K, res);
+ res = kexact_to_inexact(K, res);
+ krooted_tvs_pop(K);
+ krooted_vars_pop(K);
+ krooted_vars_pop(K);
+ return res;
}
case K_TEINF:
- if (kfinitep(n1) || !kfinitep(n2)) {
- return i2tv(0);
- } else { /* infinite n1, finite n2 */
- /* ASK John: is this behaviour for infinities ok? */
- klispE_throw_simple(K, "x0 doesn't exists");
- return KINERT;
- }
+ if (kfinitep(n1) || !kfinitep(n2)) {
+ return i2tv(0);
+ } else { /* infinite n1, finite n2 */
+ /* ASK John: is this behaviour for infinities ok? */
+ klispE_throw_simple(K, "x0 doesn't exists");
+ return KINERT;
+ }
case K_TIINF:
- if (kfinitep(n1) || !kfinitep(n2)) {
- return d2tv(0.0);
- } else { /* infinite n1, finite n2 */
- /* ASK John: is this behaviour for infinities ok? */
- klispE_throw_simple(K, "x0 doesn't exists");
- return KINERT;
- }
+ if (kfinitep(n1) || !kfinitep(n2)) {
+ return d2tv(0.0);
+ } else { /* infinite n1, finite n2 */
+ /* ASK John: is this behaviour for infinities ok? */
+ klispE_throw_simple(K, "x0 doesn't exists");
+ return KINERT;
+ }
default:
- klispE_throw_simple(K, "unsupported type");
- return KINERT;
+ klispE_throw_simple(K, "unsupported type");
+ return KINERT;
}
}
@@ -889,50 +889,50 @@ void kplus(klisp_State *K)
TValue tail = ptree;
while(apairs--) {
- TValue first = kcar(tail);
- tail = kcdr(tail);
+ TValue first = kcar(tail);
+ tail = kcdr(tail);
- /* may throw an exception */
- ares = knum_plus(K, ares, first);
+ /* may throw an exception */
+ ares = knum_plus(K, ares, first);
}
/* next the cyclic part */
TValue cres = i2tv(0); /* push it only if needed */
if (cpairs == 0 && !ttisnwnpv(ares)) { /* #undefined or #real */
- /* speed things up if there is no cycle and
- no possible error (on no primary value) */
- res = ares;
- krooted_vars_pop(K);
+ /* speed things up if there is no cycle and
+ no possible error (on no primary value) */
+ res = ares;
+ krooted_vars_pop(K);
} else {
- bool all_zero = true;
- bool all_exact = true;
-
- krooted_vars_push(K, &cres);
- while(cpairs--) {
- TValue first = kcar(tail);
- tail = kcdr(tail);
-
- all_zero = all_zero && kfast_zerop(first);
- all_exact = all_exact && ttisexact(first);
-
- cres = knum_plus(K, cres, first);
- }
-
- if (ttisnwnpv(cres)) /* #undefined or #real */
- ; /* do nothing, check is made later */
- else if (kfast_zerop(cres)) {
- if (!all_zero)
- cres = KRWNPV; /* check is made later */
- } else if (all_exact)
- cres = knegativep(cres)? KEMINF : KEPINF;
- else
- cres = knegativep(cres)? KIMINF : KIPINF;
-
- /* here if any of the two has no primary an error is signaled */
- res = knum_plus(K, ares, cres);
- krooted_vars_pop(K);
- krooted_vars_pop(K);
+ bool all_zero = true;
+ bool all_exact = true;
+
+ krooted_vars_push(K, &cres);
+ while(cpairs--) {
+ TValue first = kcar(tail);
+ tail = kcdr(tail);
+
+ all_zero = all_zero && kfast_zerop(first);
+ all_exact = all_exact && ttisexact(first);
+
+ cres = knum_plus(K, cres, first);
+ }
+
+ if (ttisnwnpv(cres)) /* #undefined or #real */
+ ; /* do nothing, check is made later */
+ else if (kfast_zerop(cres)) {
+ if (!all_zero)
+ cres = KRWNPV; /* check is made later */
+ } else if (all_exact)
+ cres = knegativep(cres)? KEMINF : KEPINF;
+ else
+ cres = knegativep(cres)? KIMINF : KIPINF;
+
+ /* here if any of the two has no primary an error is signaled */
+ res = knum_plus(K, ares, cres);
+ krooted_vars_pop(K);
+ krooted_vars_pop(K);
}
kapply_cc(K, res);
}
@@ -959,61 +959,61 @@ void ktimes(klisp_State *K)
krooted_vars_push(K, &ares);
while(apairs--) {
- TValue first = kcar(tail);
- tail = kcdr(tail);
- ares = knum_times(K, ares, first);
+ TValue first = kcar(tail);
+ tail = kcdr(tail);
+ ares = knum_times(K, ares, first);
}
/* next the cyclic part */
TValue cres = i2tv(1);
if (cpairs == 0 && !ttisnwnpv(ares)) { /* #undefined or #real */
- /* speed things up if there is no cycle */
- res = ares;
- krooted_vars_pop(K);
+ /* speed things up if there is no cycle */
+ res = ares;
+ krooted_vars_pop(K);
} else {
- bool all_one = true;
- bool all_exact = true;
-
- krooted_vars_push(K, &cres);
- while(cpairs--) {
- TValue first = kcar(tail);
- tail = kcdr(tail);
- all_one = all_one && kfast_onep(first);
- all_exact = all_exact && ttisexact(first);
- cres = knum_times(K, cres, first);
- }
-
- /* think of cres as the product of an infinite series */
- if (ttisnwnpv(ares))
- ; /* do nothing */
- if (kfast_zerop(cres))
- ; /* do nothing */
- else if (kpositivep(cres) && knum_ltp(K, cres, i2tv(1))) {
- if (all_exact)
- cres = i2tv(0);
- else
- cres = d2tv(0.0);
- }
- else if (kfast_onep(cres)) {
- if (all_one) {
- if (all_exact)
- cres = i2tv(1);
- else
- cres = d2tv(1.0);
- } else
- cres = KRWNPV;
- } else if (knum_gtp(K, cres, i2tv(1))) {
- /* ASK JOHN: this is as per the report, but maybe we should check
- that all elements are positive... */
- cres = all_exact? KEPINF : KIPINF;
- } else
- cres = KRWNPV;
-
- /* this will throw error if necessary on no primary value */
- res = knum_times(K, ares, cres);
- krooted_vars_pop(K);
- krooted_vars_pop(K);
+ bool all_one = true;
+ bool all_exact = true;
+
+ krooted_vars_push(K, &cres);
+ while(cpairs--) {
+ TValue first = kcar(tail);
+ tail = kcdr(tail);
+ all_one = all_one && kfast_onep(first);
+ all_exact = all_exact && ttisexact(first);
+ cres = knum_times(K, cres, first);
+ }
+
+ /* think of cres as the product of an infinite series */
+ if (ttisnwnpv(ares))
+ ; /* do nothing */
+ if (kfast_zerop(cres))
+ ; /* do nothing */
+ else if (kpositivep(cres) && knum_ltp(K, cres, i2tv(1))) {
+ if (all_exact)
+ cres = i2tv(0);
+ else
+ cres = d2tv(0.0);
+ }
+ else if (kfast_onep(cres)) {
+ if (all_one) {
+ if (all_exact)
+ cres = i2tv(1);
+ else
+ cres = d2tv(1.0);
+ } else
+ cres = KRWNPV;
+ } else if (knum_gtp(K, cres, i2tv(1))) {
+ /* ASK JOHN: this is as per the report, but maybe we should check
+ that all elements are positive... */
+ cres = all_exact? KEPINF : KIPINF;
+ } else
+ cres = KRWNPV;
+
+ /* this will throw error if necessary on no primary value */
+ res = knum_times(K, ares, cres);
+ krooted_vars_pop(K);
+ krooted_vars_pop(K);
}
kapply_cc(K, res);
}
@@ -1032,11 +1032,11 @@ void kminus(klisp_State *K)
/* - in kernel (and unlike in scheme) requires at least 2 arguments */
if (!ttispair(ptree) || !ttispair(kcdr(ptree))) {
- klispE_throw_simple(K, "at least two values are required");
- return;
+ klispE_throw_simple(K, "at least two values are required");
+ return;
} else if (!knumberp(kcar(ptree))) {
- klispE_throw_simple(K, "bad type on first argument (expected number)");
- return;
+ klispE_throw_simple(K, "bad type on first argument (expected number)");
+ return;
}
TValue first_val = kcar(ptree);
check_typed_list(K, knumberp, true, kcdr(ptree), &pairs, &cpairs);
@@ -1051,48 +1051,48 @@ void kminus(klisp_State *K)
krooted_vars_push(K, &ares);
while(apairs--) {
- TValue first = kcar(tail);
- tail = kcdr(tail);
- ares = knum_plus(K, ares, first);
+ TValue first = kcar(tail);
+ tail = kcdr(tail);
+ ares = knum_plus(K, ares, first);
}
/* next the cyclic part */
TValue cres = i2tv(0); /* push it only if needed */
if (cpairs == 0 && !ttisnwnpv(ares)) { /* #undefined or #real */
- /* speed things up if there is no cycle and
- no possible error (on no primary value) */
- res = ares;
- krooted_vars_pop(K);
+ /* speed things up if there is no cycle and
+ no possible error (on no primary value) */
+ res = ares;
+ krooted_vars_pop(K);
} else {
- bool all_zero = true;
- bool all_exact = true;
-
- krooted_vars_push(K, &cres);
- while(cpairs--) {
- TValue first = kcar(tail);
- tail = kcdr(tail);
-
- all_zero = all_zero && kfast_zerop(first);
- all_exact = all_exact && ttisexact(first);
-
- cres = knum_plus(K, cres, first);
- }
-
- if (ttisnwnpv(cres)) /* #undefined or #real */
- ; /* do nothing, check is made later */
- else if (kfast_zerop(cres)) {
- if (!all_zero)
- cres = KRWNPV; /* check is made later */
- } else if (all_exact)
- cres = knegativep(cres)? KEMINF : KEPINF;
- else
- cres = knegativep(cres)? KIMINF : KIPINF;
-
- /* here if any of the two has no primary an error is signaled */
- res = knum_plus(K, ares, cres);
- krooted_vars_pop(K);
- krooted_vars_pop(K);
+ bool all_zero = true;
+ bool all_exact = true;
+
+ krooted_vars_push(K, &cres);
+ while(cpairs--) {
+ TValue first = kcar(tail);
+ tail = kcdr(tail);
+
+ all_zero = all_zero && kfast_zerop(first);
+ all_exact = all_exact && ttisexact(first);
+
+ cres = knum_plus(K, cres, first);
+ }
+
+ if (ttisnwnpv(cres)) /* #undefined or #real */
+ ; /* do nothing, check is made later */
+ else if (kfast_zerop(cres)) {
+ if (!all_zero)
+ cres = KRWNPV; /* check is made later */
+ } else if (all_exact)
+ cres = knegativep(cres)? KEMINF : KEPINF;
+ else
+ cres = knegativep(cres)? KIMINF : KIPINF;
+
+ /* here if any of the two has no primary an error is signaled */
+ res = knum_plus(K, ares, cres);
+ krooted_vars_pop(K);
+ krooted_vars_pop(K);
}
/* now substract the sum of all the elements in the list to the first
value */
@@ -1125,13 +1125,13 @@ int32_t kfixint_div_mod(int32_t n, int32_t d, int32_t *res_mod)
/* div, mod or div-and-mod */
/* 0 <= mod0 < |d| */
if (mod < 0) {
- if (d < 0) {
- mod -= d;
- ++div;
- } else {
- mod += d;
- --div;
- }
+ if (d < 0) {
+ mod -= d;
+ ++div;
+ } else {
+ mod += d;
+ --div;
+ }
}
*res_mod = mod;
return div;
@@ -1153,21 +1153,21 @@ int32_t kfixint_div0_mod0(int32_t n, int32_t d, int32_t *res_mod)
int32_t dmax = ((d<0? -d : d) + 1) / 2;
if (mod < dmin) {
- if (d < 0) {
- mod -= d;
- ++div;
- } else {
- mod += d;
- --div;
- }
+ if (d < 0) {
+ mod -= d;
+ ++div;
+ } else {
+ mod += d;
+ --div;
+ }
} else if (mod >= dmax) {
- if (d < 0) {
- mod += d;
- --div;
- } else {
- mod -= d;
- ++div;
- }
+ if (d < 0) {
+ mod += d;
+ --div;
+ } else {
+ mod -= d;
+ ++div;
+ }
}
*res_mod = mod;
return div;
@@ -1194,147 +1194,147 @@ void kdiv_mod(klisp_State *K)
UNUSED(denv);
bind_2tp(K, ptree, "real", krealp, tv_n,
- "real", krealp, tv_d);
+ "real", krealp, tv_d);
TValue tv_div, tv_mod;
kensure_same_exactness(K, tv_n, tv_d);
if (kfast_zerop(tv_d)) {
- klispE_throw_simple(K, "division by zero");
- return;
+ klispE_throw_simple(K, "division by zero");
+ return;
}
switch(max_ttype(tv_n, tv_d)) {
case K_TFIXINT:
- /* NOTE: the only case were the result wouldn't fit in a fixint
- is INT32_MIN divided by -1, resulting in INT32_MAX + 1.
- The remainder is always < |tv_d| so no problem there, and
- the quotient is always <= |tv_n|. All that said, the code to
- correct the result returned by c operators / and % could cause
- problems if d = INT32_MIN or d = INT32_MAX so just to be safe
- we restrict d to be |d| < INT32_MAX and n to be
- |n| < INT32_MAX */
- if (!(ivalue(tv_n) <= INT32_MIN+2 || ivalue(tv_n) >= INT32_MAX-1 ||
- ivalue(tv_d) <= INT32_MIN+2 || ivalue(tv_d) >= INT32_MAX-1)) {
- int32_t div, mod;
- if ((flags & FDIV_ZERO) == 0)
- div = kfixint_div_mod(ivalue(tv_n), ivalue(tv_d), &mod);
- else
- div = kfixint_div0_mod0(ivalue(tv_n), ivalue(tv_d), &mod);
- tv_div = i2tv(div);
- tv_mod = i2tv(mod);
- break;
- } /* else fall through */
+ /* NOTE: the only case were the result wouldn't fit in a fixint
+ is INT32_MIN divided by -1, resulting in INT32_MAX + 1.
+ The remainder is always < |tv_d| so no problem there, and
+ the quotient is always <= |tv_n|. All that said, the code to
+ correct the result returned by c operators / and % could cause
+ problems if d = INT32_MIN or d = INT32_MAX so just to be safe
+ we restrict d to be |d| < INT32_MAX and n to be
+ |n| < INT32_MAX */
+ if (!(ivalue(tv_n) <= INT32_MIN+2 || ivalue(tv_n) >= INT32_MAX-1 ||
+ ivalue(tv_d) <= INT32_MIN+2 || ivalue(tv_d) >= INT32_MAX-1)) {
+ int32_t div, mod;
+ if ((flags & FDIV_ZERO) == 0)
+ div = kfixint_div_mod(ivalue(tv_n), ivalue(tv_d), &mod);
+ else
+ div = kfixint_div0_mod0(ivalue(tv_n), ivalue(tv_d), &mod);
+ tv_div = i2tv(div);
+ tv_mod = i2tv(mod);
+ break;
+ } /* else fall through */
case K_TBIGINT:
- kensure_bigint(tv_n);
- kensure_bigint(tv_d);
- if ((flags & FDIV_ZERO) == 0)
- tv_div = kbigint_div_mod(K, tv_n, tv_d, &tv_mod);
- else
- tv_div = kbigint_div0_mod0(K, tv_n, tv_d, &tv_mod);
- break;
+ kensure_bigint(tv_n);
+ kensure_bigint(tv_d);
+ if ((flags & FDIV_ZERO) == 0)
+ tv_div = kbigint_div_mod(K, tv_n, tv_d, &tv_mod);
+ else
+ tv_div = kbigint_div0_mod0(K, tv_n, tv_d, &tv_mod);
+ break;
case K_TBIGRAT:
- kensure_bigrat(tv_n);
- kensure_bigrat(tv_d);
- if ((flags & FDIV_ZERO) == 0)
- tv_div = kbigrat_div_mod(K, tv_n, tv_d, &tv_mod);
- else
- tv_div = kbigrat_div0_mod0(K, tv_n, tv_d, &tv_mod);
- break;
+ kensure_bigrat(tv_n);
+ kensure_bigrat(tv_d);
+ if ((flags & FDIV_ZERO) == 0)
+ tv_div = kbigrat_div_mod(K, tv_n, tv_d, &tv_mod);
+ else
+ tv_div = kbigrat_div0_mod0(K, tv_n, tv_d, &tv_mod);
+ break;
case K_TDOUBLE: {
- /* both are double */
- double div, mod;
- if ((flags & FDIV_ZERO) == 0)
- div = kdouble_div_mod(dvalue(tv_n), dvalue(tv_d), &mod);
- else
- div = kdouble_div0_mod0(dvalue(tv_n), dvalue(tv_d), &mod);
- tv_div = ktag_double(div);
- tv_mod = ktag_double(mod);
- break;
+ /* both are double */
+ double div, mod;
+ if ((flags & FDIV_ZERO) == 0)
+ div = kdouble_div_mod(dvalue(tv_n), dvalue(tv_d), &mod);
+ else
+ div = kdouble_div0_mod0(dvalue(tv_n), dvalue(tv_d), &mod);
+ tv_div = ktag_double(div);
+ tv_mod = ktag_double(mod);
+ break;
}
case K_TEINF:
- if (ttiseinf(tv_n)) {
- klispE_throw_simple(K, "non finite dividend");
- return;
- } else { /* if (ttiseinf(tv_d)) */
- /* The semantics here are unclear, following the general
- guideline of the report that says that if an infinity is
- involved it should be understand as a limit. In that
- case once the divisor is greater in magnitude than the
- dividend the division stabilizes itself at q = 0; r = n
- if both have the same sign, and q = 1; r = +infinity if
- both have different sign (but in that case !(r < |d|)
- !!) */
+ if (ttiseinf(tv_n)) {
+ klispE_throw_simple(K, "non finite dividend");
+ return;
+ } else { /* if (ttiseinf(tv_d)) */
+ /* The semantics here are unclear, following the general
+ guideline of the report that says that if an infinity is
+ involved it should be understand as a limit. In that
+ case once the divisor is greater in magnitude than the
+ dividend the division stabilizes itself at q = 0; r = n
+ if both have the same sign, and q = 1; r = +infinity if
+ both have different sign (but in that case !(r < |d|)
+ !!) */
/* RATIONALE: if q were 0 we can't accomplish
- q * d + r = n because q * d is undefined, if q isn't zero
- then, either q*d + r is infinite or undefined so
- there's no good q. on the other hand if we want
- n - q*d = r & 0 <= r < d, r can't be infinite because it
- would be equal to d, but q*d is infinite, so there's no
- way out */
- /* throw an exception, until this is resolved */
- /* ASK John */
- klispE_throw_simple(K, "non finite divisor");
- return;
- }
+ q * d + r = n because q * d is undefined, if q isn't zero
+ then, either q*d + r is infinite or undefined so
+ there's no good q. on the other hand if we want
+ n - q*d = r & 0 <= r < d, r can't be infinite because it
+ would be equal to d, but q*d is infinite, so there's no
+ way out */
+ /* throw an exception, until this is resolved */
+ /* ASK John */
+ klispE_throw_simple(K, "non finite divisor");
+ return;
+ }
case K_TIINF:
- if (ttisiinf(tv_n)) {
- klispE_throw_simple(K, "non finite dividend");
- return;
- } else { /* if (ttiseinf(tv_d)) */
- /* The semantics here are unclear, following the general
- guideline of the report that says that if an infinity is
- involved it should be understand as a limit. In that
- case once the divisor is greater in magnitude than the
- dividend the division stabilizes itself at q = 0; r = n
- if both have the same sign, and q = 1; r = +infinity if
- both have different sign (but in that case !(r < |d|)
- !!) */
+ if (ttisiinf(tv_n)) {
+ klispE_throw_simple(K, "non finite dividend");
+ return;
+ } else { /* if (ttiseinf(tv_d)) */
+ /* The semantics here are unclear, following the general
+ guideline of the report that says that if an infinity is
+ involved it should be understand as a limit. In that
+ case once the divisor is greater in magnitude than the
+ dividend the division stabilizes itself at q = 0; r = n
+ if both have the same sign, and q = 1; r = +infinity if
+ both have different sign (but in that case !(r < |d|)
+ !!) */
/* RATIONALE: if q were 0 we can't accomplish
- q * d + r = n because q * d is undefined, if q isn't zero
- then, either q*d + r is infinite or undefined so
- there's no good q. on the other hand if we want
- n - q*d = r & 0 <= r < d, r can't be infinite because it
- would be equal to d, but q*d is infinite, so there's no
- way out */
- /* throw an exception, until this is resolved */
- /* ASK John */
- klispE_throw_simple(K, "non finite divisor");
- return;
- }
+ q * d + r = n because q * d is undefined, if q isn't zero
+ then, either q*d + r is infinite or undefined so
+ there's no good q. on the other hand if we want
+ n - q*d = r & 0 <= r < d, r can't be infinite because it
+ would be equal to d, but q*d is infinite, so there's no
+ way out */
+ /* throw an exception, until this is resolved */
+ /* ASK John */
+ klispE_throw_simple(K, "non finite divisor");
+ return;
+ }
case K_TRWNPV: { /* no primary value */
- /* ASK John: what happens with undefined & real with no primary values */
- TValue n = ttisrwnpv(tv_n)? tv_n : tv_d;
- if (kcurr_strict_arithp(K)) {
- klispE_throw_simple_with_irritants(K, "operand has no primary "
- "value", 1, n);
- return;
- } else {
- tv_div = KRWNPV;
- tv_mod = KRWNPV;
- break;
- }
+ /* ASK John: what happens with undefined & real with no primary values */
+ TValue n = ttisrwnpv(tv_n)? tv_n : tv_d;
+ if (kcurr_strict_arithp(K)) {
+ klispE_throw_simple_with_irritants(K, "operand has no primary "
+ "value", 1, n);
+ return;
+ } else {
+ tv_div = KRWNPV;
+ tv_mod = KRWNPV;
+ break;
+ }
}
default:
- klispE_throw_simple(K, "unsupported type");
- return;
+ klispE_throw_simple(K, "unsupported type");
+ return;
}
TValue res;
if (flags & FDIV_DIV) {
- if (flags & FDIV_MOD) { /* return both div and mod */
- krooted_tvs_push(K, tv_div);
- krooted_tvs_push(K, tv_mod);
- res = klist(K, 2, tv_div, tv_mod);
- krooted_tvs_pop(K);
- krooted_tvs_pop(K);
- } else {
- res = tv_div;
- }
+ if (flags & FDIV_MOD) { /* return both div and mod */
+ krooted_tvs_push(K, tv_div);
+ krooted_tvs_push(K, tv_mod);
+ res = klist(K, 2, tv_div, tv_mod);
+ krooted_tvs_pop(K);
+ krooted_tvs_pop(K);
+ } else {
+ res = tv_div;
+ }
} else {
- res = tv_mod;
+ res = tv_mod;
}
kapply_cc(K, res);
}
@@ -1352,16 +1352,16 @@ bool koddp(TValue n)
{
switch (ttype(n)) {
case K_TFIXINT:
- return (ivalue(n) & 1) != 0;
+ return (ivalue(n) & 1) != 0;
case K_TBIGINT:
- return kbigint_oddp(n);
+ return kbigint_oddp(n);
case K_TDOUBLE:
- return fmod(dvalue(n), 2.0) != 0.0;
- /* real with no prim value, complex and undefined should be captured by
- type predicate */
+ return fmod(dvalue(n), 2.0) != 0.0;
+ /* real with no prim value, complex and undefined should be captured by
+ type predicate */
default:
- assert(0);
- return false;
+ assert(0);
+ return false;
}
}
@@ -1369,16 +1369,16 @@ bool kevenp(TValue n)
{
switch (ttype(n)) {
case K_TFIXINT:
- return (ivalue(n) & 1) == 0;
+ return (ivalue(n) & 1) == 0;
case K_TBIGINT:
- return kbigint_evenp(n);
+ return kbigint_evenp(n);
case K_TDOUBLE:
- return fmod(dvalue(n), 2.0) == 0.0;
- /* real with no prim value, complex and undefined should be captured by
- type predicate */
+ return fmod(dvalue(n), 2.0) == 0.0;
+ /* real with no prim value, complex and undefined should be captured by
+ type predicate */
default:
- assert(0);
- return false;
+ assert(0);
+ return false;
}
}
@@ -1430,11 +1430,11 @@ void kmin_max(klisp_State *K)
bool (*cmp)(klisp_State *K, TValue, TValue) = minp? knum_ltp : knum_gtp;
while(pairs--) {
- TValue first = kcar(tail);
- tail = kcdr(tail);
+ TValue first = kcar(tail);
+ tail = kcdr(tail);
- if ((*cmp)(K, first, res))
- res = first;
+ if ((*cmp)(K, first, res))
+ res = first;
}
kapply_cc(K, res);
}
@@ -1456,22 +1456,22 @@ void kgcd(klisp_State *K)
krooted_vars_push(K, &res);
if (pairs == 0) {
- res = KEPINF; /* report: (gcd) = #e+infinity */
+ res = KEPINF; /* report: (gcd) = #e+infinity */
} else {
- TValue tail = ptree;
- bool seen_finite_non_zero = false;
- /* res = 0 */
+ TValue tail = ptree;
+ bool seen_finite_non_zero = false;
+ /* res = 0 */
- while(pairs--) {
- TValue first = kcar(tail);
- tail = kcdr(tail);
- seen_finite_non_zero |=
- (!ttisinf(first) && !kfast_zerop(first));
- res = knum_gcd(K, res, first);
- }
+ while(pairs--) {
+ TValue first = kcar(tail);
+ tail = kcdr(tail);
+ seen_finite_non_zero |=
+ (!ttisinf(first) && !kfast_zerop(first));
+ res = knum_gcd(K, res, first);
+ }
- if (!seen_finite_non_zero)
- res = KRWNPV;
+ if (!seen_finite_non_zero)
+ res = KRWNPV;
}
krooted_vars_pop(K);
@@ -1496,10 +1496,10 @@ void klcm(klisp_State *K)
TValue tail = ptree;
while(pairs--) {
- TValue first = kcar(tail);
- tail = kcdr(tail);
- /* This will check that neither is zero */
- res = knum_lcm(K, res, first);
+ TValue first = kcar(tail);
+ tail = kcdr(tail);
+ /* This will check that neither is zero */
+ res = knum_lcm(K, res, first);
}
krooted_vars_pop(K);
@@ -1526,9 +1526,9 @@ void kget_real_internal_bounds(klisp_State *K)
[-inf, +inf] bounds */
TValue res;
if (ttisexact(tv_n)) {
- res = klist(K, 2, tv_n, tv_n);
+ res = klist(K, 2, tv_n, tv_n);
} else {
- res = klist(K, 2, KIMINF, KIPINF);
+ res = klist(K, 2, KIMINF, KIPINF);
}
kapply_cc(K, res);
}
@@ -1549,9 +1549,9 @@ void kget_real_exact_bounds(klisp_State *K)
+inf when converting to exact */
TValue res;
if (ttisexact(tv_n)) {
- res = klist(K, 2, tv_n, tv_n);
+ res = klist(K, 2, tv_n, tv_n);
} else {
- res = klist(K, 2, KEMINF, KEPINF);
+ res = klist(K, 2, KEMINF, KEPINF);
}
kapply_cc(K, res);
}
@@ -1569,10 +1569,10 @@ void kget_real_internal_primary(klisp_State *K)
bind_1tp(K, ptree, "real", krealp, tv_n);
/* TEMP: do it here directly */
if (ttisrwnpv(tv_n)) {
- klispE_throw_simple_with_irritants(K, "no primary value", 1, tv_n);
- return;
+ klispE_throw_simple_with_irritants(K, "no primary value", 1, tv_n);
+ return;
} else {
- kapply_cc(K, tv_n);
+ kapply_cc(K, tv_n);
}
}
@@ -1603,17 +1603,17 @@ void kmake_inexact(klisp_State *K)
UNUSED(xparams);
bind_3tp(K, ptree, "real", krealp, real1,
- "real", krealp, real2, "real", krealp, real3);
+ "real", krealp, real2, "real", krealp, real3);
TValue res;
UNUSED(real1);
UNUSED(real3);
if (ttisinexact(real2)) {
- res = real2;
+ res = real2;
} else {
- /* TEMP: for now bounds are ignored */
- /* NOTE: this handles overflow and underflow */
- res = kexact_to_inexact(K, real2);
+ /* TEMP: for now bounds are ignored */
+ /* NOTE: this handles overflow and underflow */
+ res = kexact_to_inexact(K, real2);
}
kapply_cc(K, res);
}
@@ -1660,7 +1660,7 @@ void kwith_strict_arithmetic(klisp_State *K)
UNUSED(xparams);
bind_2tp(K, ptree, "bool", ttisboolean, strictp,
- "combiner", ttiscombiner, comb);
+ "combiner", ttiscombiner, comb);
TValue op = kmake_operative(K, do_bind, 1, K->kd_strict_arith_key);
krooted_tvs_push(K, op);
@@ -1707,11 +1707,11 @@ void kdivided(klisp_State *K)
/* / in kernel (and unlike in scheme) requires at least 2 arguments */
if (!ttispair(ptree) || !ttispair(kcdr(ptree))) {
- klispE_throw_simple(K, "at least two values are required");
- return;
+ klispE_throw_simple(K, "at least two values are required");
+ return;
} else if (!knumberp(kcar(ptree))) {
- klispE_throw_simple(K, "bad type on first argument (expected number)");
- return;
+ klispE_throw_simple(K, "bad type on first argument (expected number)");
+ return;
}
TValue first_val = kcar(ptree);
check_typed_list(K, knumberp, true, kcdr(ptree), &pairs, &cpairs);
@@ -1726,61 +1726,61 @@ void kdivided(klisp_State *K)
krooted_vars_push(K, &ares);
while(apairs--) {
- TValue first = kcar(tail);
- tail = kcdr(tail);
- ares = knum_times(K, ares, first);
+ TValue first = kcar(tail);
+ tail = kcdr(tail);
+ ares = knum_times(K, ares, first);
}
/* next the cyclic part */
TValue cres = i2tv(1);
if (cpairs == 0 && !ttisnwnpv(ares)) { /* #undefined or #real */
- /* speed things up if there is no cycle */
- res = ares;
- krooted_vars_pop(K);
+ /* speed things up if there is no cycle */
+ res = ares;
+ krooted_vars_pop(K);
} else {
- bool all_one = true;
- bool all_exact = true;
-
- krooted_vars_push(K, &cres);
- while(cpairs--) {
- TValue first = kcar(tail);
- tail = kcdr(tail);
- all_one = all_one && kfast_onep(first);
- all_exact = all_exact && ttisexact(first);
- cres = knum_times(K, cres, first);
- }
-
- /* think of cres as the product of an infinite series */
- if (ttisnwnpv(ares))
- ; /* do nothing */
- if (kfast_zerop(cres))
- ; /* do nothing */
- else if (kpositivep(cres) && knum_ltp(K, cres, i2tv(1))) {
- if (all_exact)
- cres = i2tv(0);
- else
- cres = d2tv(0.0);
- }
- else if (kfast_onep(cres)) {
- if (all_one) {
- if (all_exact)
- cres = i2tv(1);
- else
- cres = d2tv(1.0);
- } else
- cres = KRWNPV;
- } else if (knum_gtp(K, cres, i2tv(1))) {
- /* ASK JOHN: this is as per the report, but maybe we should check
- that all elements are positive... */
- cres = all_exact? KEPINF : KIPINF;
- } else
- cres = KRWNPV;
-
- /* this will throw error if necessary on no primary value */
- res = knum_times(K, ares, cres);
- krooted_vars_pop(K);
- krooted_vars_pop(K);
+ bool all_one = true;
+ bool all_exact = true;
+
+ krooted_vars_push(K, &cres);
+ while(cpairs--) {
+ TValue first = kcar(tail);
+ tail = kcdr(tail);
+ all_one = all_one && kfast_onep(first);
+ all_exact = all_exact && ttisexact(first);
+ cres = knum_times(K, cres, first);
+ }
+
+ /* think of cres as the product of an infinite series */
+ if (ttisnwnpv(ares))
+ ; /* do nothing */
+ if (kfast_zerop(cres))
+ ; /* do nothing */
+ else if (kpositivep(cres) && knum_ltp(K, cres, i2tv(1))) {
+ if (all_exact)
+ cres = i2tv(0);
+ else
+ cres = d2tv(0.0);
+ }
+ else if (kfast_onep(cres)) {
+ if (all_one) {
+ if (all_exact)
+ cres = i2tv(1);
+ else
+ cres = d2tv(1.0);
+ } else
+ cres = KRWNPV;
+ } else if (knum_gtp(K, cres, i2tv(1))) {
+ /* ASK JOHN: this is as per the report, but maybe we should check
+ that all elements are positive... */
+ cres = all_exact? KEPINF : KIPINF;
+ } else
+ cres = KRWNPV;
+
+ /* this will throw error if necessary on no primary value */
+ res = knum_times(K, ares, cres);
+ krooted_vars_pop(K);
+ krooted_vars_pop(K);
}
/* now divide first value by the product of all the elements in the list */
@@ -1853,7 +1853,7 @@ void krationalize(klisp_State *K)
UNUSED(xparams);
bind_2tp(K, ptree, "real", krealp, n1,
- "real", krealp, n2);
+ "real", krealp, n2);
TValue res = knum_rationalize(K, n1, n2);
kapply_cc(K, res);
@@ -1869,7 +1869,7 @@ void ksimplest_rational(klisp_State *K)
UNUSED(xparams);
bind_2tp(K, ptree, "real", krealp, n1,
- "real", krealp, n2);
+ "real", krealp, n2);
TValue res = knum_simplest_rational(K, n1, n2);
kapply_cc(K, res);
@@ -1892,26 +1892,26 @@ void kexp(klisp_State *K)
case K_TFIXINT:
case K_TBIGINT:
case K_TBIGRAT:
- /* for now, all go to double */
- n = kexact_to_inexact(K, n); /* no need to root it */
- /* fall through */
+ /* for now, all go to double */
+ n = kexact_to_inexact(K, n); /* no need to root it */
+ /* fall through */
case K_TDOUBLE: {
- double d = exp(dvalue(n));
- res = ktag_double(d);
- break;
+ double d = exp(dvalue(n));
+ res = ktag_double(d);
+ break;
}
case K_TEINF: /* in any case return inexact result (e is inexact) */
case K_TIINF:
- res = kpositivep(n)? KIPINF : d2tv(0.0);
- break;
+ res = kpositivep(n)? KIPINF : d2tv(0.0);
+ break;
case K_TRWNPV:
case K_TUNDEFINED:
- klispE_throw_simple_with_irritants(K, "no primary value", 1, n);
- return;
- /* complex and undefined should be captured by type predicate */
+ klispE_throw_simple_with_irritants(K, "no primary value", 1, n);
+ return;
+ /* complex and undefined should be captured by type predicate */
default:
- klispE_throw_simple(K, "unsupported type");
- return;
+ klispE_throw_simple(K, "unsupported type");
+ return;
}
kapply_cc(K, res);
}
@@ -1929,11 +1929,11 @@ void klog(klisp_State *K)
/* ASK John: error or no primary value, or undefined */
if (kfast_zerop(n)) {
- klispE_throw_simple_with_irritants(K, "zero argument", 1, n);
- return;
+ klispE_throw_simple_with_irritants(K, "zero argument", 1, n);
+ return;
} else if (knegativep(n)) {
- klispE_throw_simple_with_irritants(K, "negative argument", 1, n);
- return;
+ klispE_throw_simple_with_irritants(K, "negative argument", 1, n);
+ return;
}
/* TEMP: do it inline for now */
@@ -1942,27 +1942,27 @@ void klog(klisp_State *K)
case K_TFIXINT:
case K_TBIGINT:
case K_TBIGRAT:
- /* for now, all go to double */
- n = kexact_to_inexact(K, n); /* no need to root it */
- /* fall through */
+ /* for now, all go to double */
+ n = kexact_to_inexact(K, n); /* no need to root it */
+ /* fall through */
case K_TDOUBLE: {
- double d = log(dvalue(n));
- res = ktag_double(d);
- break;
+ double d = log(dvalue(n));
+ res = ktag_double(d);
+ break;
}
case K_TEINF: /* in any case return inexact result (e is inexact) */
case K_TIINF:
- /* is this ok? */
- res = KIPINF;
- break;
+ /* is this ok? */
+ res = KIPINF;
+ break;
case K_TRWNPV:
case K_TUNDEFINED:
- klispE_throw_simple_with_irritants(K, "no primary value", 1, n);
- return;
- /* complex and undefined should be captured by type predicate */
+ klispE_throw_simple_with_irritants(K, "no primary value", 1, n);
+ return;
+ /* complex and undefined should be captured by type predicate */
default:
- klispE_throw_simple(K, "unsupported type");
- return;
+ klispE_throw_simple(K, "unsupported type");
+ return;
}
kapply_cc(K, res);
}
@@ -1987,26 +1987,26 @@ void ktrig(klisp_State *K)
case K_TFIXINT:
case K_TBIGINT:
case K_TBIGRAT:
- /* for now, all go to double */
- n = kexact_to_inexact(K, n); /* no need to root it */
- /* fall through */
+ /* for now, all go to double */
+ n = kexact_to_inexact(K, n); /* no need to root it */
+ /* fall through */
case K_TDOUBLE: {
- double d = (*fn)(dvalue(n));
- res = ktag_double(d);
- break;
+ double d = (*fn)(dvalue(n));
+ res = ktag_double(d);
+ break;
}
case K_TEINF:
case K_TIINF:
- /* is this ok? */
- res = KRWNPV;
- break;
+ /* is this ok? */
+ res = KRWNPV;
+ break;
case K_TRWNPV:
case K_TUNDEFINED:
- klispE_throw_simple_with_irritants(K, "no primary value", 1, n);
- return;
+ klispE_throw_simple_with_irritants(K, "no primary value", 1, n);
+ return;
default:
- klispE_throw_simple(K, "unsupported type");
- return;
+ klispE_throw_simple(K, "unsupported type");
+ return;
}
arith_kapply_cc(K, res);
}
@@ -2031,31 +2031,31 @@ void katrig(klisp_State *K)
case K_TFIXINT:
case K_TBIGINT:
case K_TBIGRAT:
- /* for now, all go to double */
- n = kexact_to_inexact(K, n); /* no need to root it */
- /* fall through */
+ /* for now, all go to double */
+ n = kexact_to_inexact(K, n); /* no need to root it */
+ /* fall through */
case K_TDOUBLE: {
- double d = dvalue(n);
- if (d >= -1.0 && d <= 1.0) {
- d = (*fn)(dvalue(n));
- res = ktag_double(d);
- } else {
- res = KUNDEF; /* ASK John: is this ok, or should throw error? */
- }
- break;
+ double d = dvalue(n);
+ if (d >= -1.0 && d <= 1.0) {
+ d = (*fn)(dvalue(n));
+ res = ktag_double(d);
+ } else {
+ res = KUNDEF; /* ASK John: is this ok, or should throw error? */
+ }
+ break;
}
case K_TEINF:
case K_TIINF:
- /* ASK John: is this ok? */
- res = KRWNPV;
- break;
+ /* ASK John: is this ok? */
+ res = KRWNPV;
+ break;
case K_TRWNPV:
case K_TUNDEFINED:
- klispE_throw_simple_with_irritants(K, "no primary value", 1, n);
- return;
+ klispE_throw_simple_with_irritants(K, "no primary value", 1, n);
+ return;
default:
- klispE_throw_simple(K, "unsupported type");
- return;
+ klispE_throw_simple(K, "unsupported type");
+ return;
}
arith_kapply_cc(K, res);
}
@@ -2073,22 +2073,22 @@ void katan(klisp_State *K)
bool two_params;
TValue n2;
if (ttisnil(rest)) {
- two_params = false;
- n2 = n1;
+ two_params = false;
+ n2 = n1;
} else {
- two_params = true;
- if (!ttispair(rest) || !ttisnil(kcdr(rest))) {
- klispE_throw_simple(K, "Bad ptree structure (in optional "
- "argument)");
- return;
- } else if (!ttisnumber(kcar(rest))) {
- klispE_throw_simple(K, "Bad type on optional argument "
- "(expected number)");
- return;
- } else {
- n2 = kcar(rest);
- kensure_same_exactness(K, n1, n2);
- }
+ two_params = true;
+ if (!ttispair(rest) || !ttisnil(kcdr(rest))) {
+ klispE_throw_simple(K, "Bad ptree structure (in optional "
+ "argument)");
+ return;
+ } else if (!ttisnumber(kcar(rest))) {
+ klispE_throw_simple(K, "Bad type on optional argument "
+ "(expected number)");
+ return;
+ } else {
+ n2 = kcar(rest);
+ kensure_same_exactness(K, n1, n2);
+ }
}
/* TEMP: do it inline for now */
@@ -2097,56 +2097,56 @@ void katan(klisp_State *K)
case K_TFIXINT:
case K_TBIGINT:
case K_TBIGRAT:
- /* for now, all go to double */
- n1 = kexact_to_inexact(K, n1); /* no need to root it */
- if (two_params)
- n2 = kexact_to_inexact(K, n2); /* no need to root it */
- /* fall through */
+ /* for now, all go to double */
+ n1 = kexact_to_inexact(K, n1); /* no need to root it */
+ if (two_params)
+ n2 = kexact_to_inexact(K, n2); /* no need to root it */
+ /* fall through */
case K_TDOUBLE: {
- double d1 = dvalue(n1);
- if (two_params) {
- double d2 = dvalue(n2);
- d1 = atan2(d1, d2);
- } else {
- d1 = atan(d1);
- }
- res = ktag_double(d1);
- break;
+ double d1 = dvalue(n1);
+ if (two_params) {
+ double d2 = dvalue(n2);
+ d1 = atan2(d1, d2);
+ } else {
+ d1 = atan(d1);
+ }
+ res = ktag_double(d1);
+ break;
}
case K_TEINF:
case K_TIINF:
- /* ASK John: is this ok? */
- if (two_params) {
- if (kfinitep(n1)) {
- res = ktag_double(0.0);
- } else if (!kfinitep(n2)) {
- klispE_throw_simple_with_irritants(K, "infinite divisor & "
- "dividend", 2, n1, n2);
- return;
- } else {
- /* XXX either pi/2 or -pi/2, but we don't have the constant */
- double d = knum_same_signp(K, n1, n2)? atan(INFINITY) :
- atan(-INFINITY);
- res = ktag_double(d);
- }
- } else {
- /* XXX either pi/2 or -pi/2, but we don't have the constant */
- double d = kpositivep(n1)? atan(INFINITY) : atan(-INFINITY);
- res = ktag_double(d);
- }
- break;
+ /* ASK John: is this ok? */
+ if (two_params) {
+ if (kfinitep(n1)) {
+ res = ktag_double(0.0);
+ } else if (!kfinitep(n2)) {
+ klispE_throw_simple_with_irritants(K, "infinite divisor & "
+ "dividend", 2, n1, n2);
+ return;
+ } else {
+ /* XXX either pi/2 or -pi/2, but we don't have the constant */
+ double d = knum_same_signp(K, n1, n2)? atan(INFINITY) :
+ atan(-INFINITY);
+ res = ktag_double(d);
+ }
+ } else {
+ /* XXX either pi/2 or -pi/2, but we don't have the constant */
+ double d = kpositivep(n1)? atan(INFINITY) : atan(-INFINITY);
+ res = ktag_double(d);
+ }
+ break;
case K_TRWNPV:
case K_TUNDEFINED:
- if (two_params) {
- klispE_throw_simple_with_irritants(K, "no primary value", 2,
- n1, n2);
- } else {
- klispE_throw_simple_with_irritants(K, "no primary value", 1, n1);
- }
- return;
+ if (two_params) {
+ klispE_throw_simple_with_irritants(K, "no primary value", 2,
+ n1, n2);
+ } else {
+ klispE_throw_simple_with_irritants(K, "no primary value", 1, n1);
+ }
+ return;
default:
- klispE_throw_simple(K, "unsupported type");
- return;
+ klispE_throw_simple(K, "unsupported type");
+ return;
}
arith_kapply_cc(K, res);
}
@@ -2168,30 +2168,30 @@ void ksqrt(klisp_State *K)
case K_TFIXINT:
case K_TBIGINT:
case K_TBIGRAT:
- /* TEMP: for now, all go to double */
- n = kexact_to_inexact(K, n); /* no need to root it */
- /* fall through */
+ /* TEMP: for now, all go to double */
+ n = kexact_to_inexact(K, n); /* no need to root it */
+ /* fall through */
case K_TDOUBLE: {
- double d = dvalue(n);
- if (d < 0.0)
- res = KUNDEF; /* ASK John: is this ok, or should throw error? */
- else {
- d = sqrt(d);
- res = ktag_double(d);
- }
- break;
+ double d = dvalue(n);
+ if (d < 0.0)
+ res = KUNDEF; /* ASK John: is this ok, or should throw error? */
+ else {
+ d = sqrt(d);
+ res = ktag_double(d);
+ }
+ break;
}
case K_TEINF:
case K_TIINF:
- res = knegativep(n)? KUNDEF : KIPINF;
- break;
+ res = knegativep(n)? KUNDEF : KIPINF;
+ break;
case K_TRWNPV:
case K_TUNDEFINED:
- klispE_throw_simple_with_irritants(K, "no primary value", 1, n);
- return;
+ klispE_throw_simple_with_irritants(K, "no primary value", 1, n);
+ return;
default:
- klispE_throw_simple(K, "unsupported type");
- return;
+ klispE_throw_simple(K, "unsupported type");
+ return;
}
arith_kapply_cc(K, res);
}
@@ -2206,7 +2206,7 @@ void kexpt(klisp_State *K)
UNUSED(xparams);
bind_2tp(K, ptree, "number", knumberp, n1,
- "number", knumberp, n2);
+ "number", knumberp, n2);
kensure_same_exactness(K, n1, n2);
@@ -2216,56 +2216,56 @@ void kexpt(klisp_State *K)
case K_TFIXINT:
case K_TBIGINT:
case K_TBIGRAT:
- /* TEMP: for now, all go to double */
- n1 = kexact_to_inexact(K, n1); /* no need to root it */
- n2 = kexact_to_inexact(K, n2); /* no need to root it */
- /* fall through */
+ /* TEMP: for now, all go to double */
+ n1 = kexact_to_inexact(K, n1); /* no need to root it */
+ n2 = kexact_to_inexact(K, n2); /* no need to root it */
+ /* fall through */
case K_TDOUBLE: {
- double d1 = dvalue(n1);
- double d2 = dvalue(n2);
- d1 = pow(d1, d2);
- res = ktag_double(d1);
- break;
+ double d1 = dvalue(n1);
+ double d2 = dvalue(n2);
+ d1 = pow(d1, d2);
+ res = ktag_double(d1);
+ break;
}
case K_TEINF:
case K_TIINF:
- if (ttisinf(n1) && ttisinf(n2)) {
- if (knegativep(n1) && knegativep(n2))
- res = d2tv(0.0);
- else if (knegativep(n1) || knegativep(n2))
- res = KUNDEF; /* ASK John: is this ok? */
- else
- res = KIPINF;
- } else if (ttisinf(n1)) {
- if (knegativep(n1)) {
- if (knegativep(n2))
- res = d2tv(0.0);
- else {
- TValue num = knum_numerator(K, n2);
- krooted_tvs_push(K, num);
- res = kevenp(num)? KIPINF : KIMINF;
- krooted_tvs_pop(K);
- }
- } else {
- res = KIPINF;
- }
- } else { /* ttisinf(n2) */
- if (knegativep(n2))
- res = d2tv(0.0);
- else if (knegativep(n1))
- res = KUNDEF; /* ASK John: is this ok? */
- else
- res = KIPINF;
- }
- break;
+ if (ttisinf(n1) && ttisinf(n2)) {
+ if (knegativep(n1) && knegativep(n2))
+ res = d2tv(0.0);
+ else if (knegativep(n1) || knegativep(n2))
+ res = KUNDEF; /* ASK John: is this ok? */
+ else
+ res = KIPINF;
+ } else if (ttisinf(n1)) {
+ if (knegativep(n1)) {
+ if (knegativep(n2))
+ res = d2tv(0.0);
+ else {
+ TValue num = knum_numerator(K, n2);
+ krooted_tvs_push(K, num);
+ res = kevenp(num)? KIPINF : KIMINF;
+ krooted_tvs_pop(K);
+ }
+ } else {
+ res = KIPINF;
+ }
+ } else { /* ttisinf(n2) */
+ if (knegativep(n2))
+ res = d2tv(0.0);
+ else if (knegativep(n1))
+ res = KUNDEF; /* ASK John: is this ok? */
+ else
+ res = KIPINF;
+ }
+ break;
case K_TRWNPV:
case K_TUNDEFINED:
- klispE_throw_simple_with_irritants(K, "no primary value", 2,
- n1, n2);
- return;
+ klispE_throw_simple_with_irritants(K, "no primary value", 2,
+ n1, n2);
+ return;
default:
- klispE_throw_simple(K, "unsupported type");
- return;
+ klispE_throw_simple(K, "unsupported type");
+ return;
}
arith_kapply_cc(K, res);
}
@@ -2285,7 +2285,7 @@ void number_to_string(klisp_State *K)
bind_al1tp(K, ptree, "number", knumberp, obj, maybe_radix);
int radix = 10;
if (get_opt_tpar(K, maybe_radix, "radix (2, 8, 10, or 16)", ttisradix))
- radix = ivalue(maybe_radix);
+ radix = ivalue(maybe_radix);
char small_buf[64]; /* for fixints */
TValue buf_str = K->empty_string; /* for bigrats, bigints and doubles */
@@ -2294,87 +2294,87 @@ void number_to_string(klisp_State *K)
switch(ttype(obj)) {
case K_TFIXINT: {
- /* can't use snprintf here... there's no support for binary,
- so just do by hand */
- uint32_t value;
- /* convert to unsigned to write */
- value = (uint32_t) ((ivalue(obj) < 0)?
- -((int64_t) ivalue(obj)) :
- ivalue(obj));
- char *digits = "0123456789abcdef";
- /* write backwards so we don't have to reverse the buffer */
- buf = small_buf + sizeof(small_buf) - 1;
- *buf-- = '\0';
- do {
- *buf-- = digits[value % radix];
- value /= radix;
- } while(value > 0); /* with the guard down it works for zero too */
-
- /* only put the sign if negative,
- then correct the pointer to the first char */
- if (ivalue(obj) < 0)
- *buf = '-';
- else
- ++buf;
- break;
+ /* can't use snprintf here... there's no support for binary,
+ so just do by hand */
+ uint32_t value;
+ /* convert to unsigned to write */
+ value = (uint32_t) ((ivalue(obj) < 0)?
+ -((int64_t) ivalue(obj)) :
+ ivalue(obj));
+ char *digits = "0123456789abcdef";
+ /* write backwards so we don't have to reverse the buffer */
+ buf = small_buf + sizeof(small_buf) - 1;
+ *buf-- = '\0';
+ do {
+ *buf-- = digits[value % radix];
+ value /= radix;
+ } while(value > 0); /* with the guard down it works for zero too */
+
+ /* only put the sign if negative,
+ then correct the pointer to the first char */
+ if (ivalue(obj) < 0)
+ *buf = '-';
+ else
+ ++buf;
+ break;
}
case K_TBIGINT: {
- int32_t size = kbigint_print_size(obj, radix);
- /* here we are using 1 byte extra, because size already includes
- 1 for the terminator, but better be safe than sorry */
- buf_str = kstring_new_s(K, size);
- buf = kstring_buf(buf_str);
- kbigint_print_string(K, obj, radix, buf, size);
- /* the string will be copied and trimmed later,
- because print_size may overestimate */
- break;
+ int32_t size = kbigint_print_size(obj, radix);
+ /* here we are using 1 byte extra, because size already includes
+ 1 for the terminator, but better be safe than sorry */
+ buf_str = kstring_new_s(K, size);
+ buf = kstring_buf(buf_str);
+ kbigint_print_string(K, obj, radix, buf, size);
+ /* the string will be copied and trimmed later,
+ because print_size may overestimate */
+ break;
}
case K_TBIGRAT: {
- int32_t size = kbigrat_print_size(obj, radix);
- /* here we are using 1 byte extra, because size already includes
- 1 for the terminator, but better be safe than sorry */
- buf_str = kstring_new_s(K, size);
- buf = kstring_buf(buf_str);
- kbigrat_print_string(K, obj, radix, buf, size);
- /* the string will be copied and trimmed later,
- because print_size may overestimate */
- break;
+ int32_t size = kbigrat_print_size(obj, radix);
+ /* here we are using 1 byte extra, because size already includes
+ 1 for the terminator, but better be safe than sorry */
+ buf_str = kstring_new_s(K, size);
+ buf = kstring_buf(buf_str);
+ kbigrat_print_string(K, obj, radix, buf, size);
+ /* the string will be copied and trimmed later,
+ because print_size may overestimate */
+ break;
}
case K_TEINF:
- buf = tv_equal(obj, KEPINF)? "#e+infinity" : "#e-infinity";
- break;
+ buf = tv_equal(obj, KEPINF)? "#e+infinity" : "#e-infinity";
+ break;
case K_TIINF:
- buf = tv_equal(obj, KIPINF)? "#i+infinity" : "#i-infinity";
- break;
+ buf = tv_equal(obj, KIPINF)? "#i+infinity" : "#i-infinity";
+ break;
case K_TDOUBLE: {
- if (radix != 10) {
- /* only radix 10 is supported for inexact numbers
- see rationale in the report (technically they could be
- printed without a decimal point, like fractions, but...*/
- klispE_throw_simple_with_irritants(K, "radix != 10 with inexact "
- "number", 2, obj,maybe_radix);
- return;
- }
+ if (radix != 10) {
+ /* only radix 10 is supported for inexact numbers
+ see rationale in the report (technically they could be
+ printed without a decimal point, like fractions, but...*/
+ klispE_throw_simple_with_irritants(K, "radix != 10 with inexact "
+ "number", 2, obj,maybe_radix);
+ return;
+ }
/* radix is always 10 */
- int32_t size = kdouble_print_size(obj);
- /* here we are using 1 byte extra, because size already includes
- 1 for the terminator, but better be safe than sorry */
- buf_str = kstring_new_s(K, size);
- buf = kstring_buf(buf_str);
- kdouble_print_string(K, obj, buf, size);
- /* the string will be copied and trimmed later,
- because print_size may overestimate */
- break;
+ int32_t size = kdouble_print_size(obj);
+ /* here we are using 1 byte extra, because size already includes
+ 1 for the terminator, but better be safe than sorry */
+ buf_str = kstring_new_s(K, size);
+ buf = kstring_buf(buf_str);
+ kdouble_print_string(K, obj, buf, size);
+ /* the string will be copied and trimmed later,
+ because print_size may overestimate */
+ break;
}
case K_TRWNPV:
- buf = "#real";
- break;
+ buf = "#real";
+ break;
case K_TUNDEFINED:
- buf = "#undefined";
- break;
+ buf = "#undefined";
+ break;
default:
- /* shouldn't happen */
- klisp_assert(0);
+ /* shouldn't happen */
+ klisp_assert(0);
}
TValue str = kstring_new_b(K, buf);
@@ -2386,16 +2386,16 @@ struct kspecial_number {
const char *ext_rep; /* downcase external representation */
TValue obj;
} kspecial_numbers[] = { { "#e+infinity", KEPINF_ },
- { "#e-infinity", KEMINF_ },
- { "#i+infinity", KIPINF_ },
- { "#i-infinity", KIMINF_ },
- { "#real", KRWNPV_ },
- { "#undefined", KUNDEF_ }
+ { "#e-infinity", KEMINF_ },
+ { "#i+infinity", KIPINF_ },
+ { "#i-infinity", KIMINF_ },
+ { "#real", KRWNPV_ },
+ { "#undefined", KUNDEF_ }
};
/* N.B. If case insignificance is removed, check here too!
- This will happily accept exactness and radix arguments in both cases
- (but not the names of special numbers) */
+ This will happily accept exactness and radix arguments in both cases
+ (but not the names of special numbers) */
void string_to_number(klisp_State *K)
{
/* MAYBE try to unify with ktoken */
@@ -2410,7 +2410,7 @@ void string_to_number(klisp_State *K)
bind_al1tp(K, ptree, "string", ttisstring, str, maybe_radix);
int radix = 10;
if (get_opt_tpar(K, maybe_radix, "radix (2, 8, 10, or 16)", ttisradix))
- radix = ivalue(maybe_radix);
+ radix = ivalue(maybe_radix);
/* track length to throw better error msgs */
char *buf = kstring_buf(str);
@@ -2425,74 +2425,74 @@ void string_to_number(klisp_State *K)
TValue res = KINERT;
size_t snum_size = sizeof(kspecial_numbers) /
- sizeof(struct kspecial_number);
+ sizeof(struct kspecial_number);
for (int i = 0; i < snum_size; i++) {
- struct kspecial_number number = kspecial_numbers[i];
- /* NOTE: must check type because buf may contain embedded '\0's */
- if (len == strlen(number.ext_rep) &&
- strcmp(number.ext_rep, buf) == 0) {
- res = number.obj;
- break;
- }
+ struct kspecial_number number = kspecial_numbers[i];
+ /* NOTE: must check type because buf may contain embedded '\0's */
+ if (len == strlen(number.ext_rep) &&
+ strcmp(number.ext_rep, buf) == 0) {
+ res = number.obj;
+ break;
+ }
}
if (ttisinert(res)) {
- /* number wasn't a special number */
- while (*buf == '#') {
- switch(*++buf) {
- case 'e': case 'E': case 'i': case 'I':
- if (has_exactp) {
- klispE_throw_simple_with_irritants(
- K, "two exactness prefixes", 1, str);
- return;
- }
- has_exactp = true;
- exactp = (*buf == 'e');
- ++buf;
- break;
- case 'b': case 'B': radix = 2; goto RADIX;
- case 'o': case 'O': radix = 8; goto RADIX;
- case 'd': case 'D': radix = 10; goto RADIX;
- case 'x': case 'X': radix = 16; goto RADIX;
- RADIX:
- if (has_radixp) {
- klispE_throw_simple_with_irritants(
- K, "two radix prefixes", 1, str);
- return;
- }
- has_radixp = true;
- ++buf;
- break;
- default:
- klispE_throw_simple_with_irritants(K, "unexpected char "
- "after #", 1, str);
- return;
- }
- }
-
- if (radix == 10) {
- /* only allow decimals with radix 10 */
- bool decimalp = false;
- if (!krational_read_decimal(K, buf, radix, &res, NULL, &decimalp)) {
- klispE_throw_simple_with_irritants(K, "Bad format", 1, str);
- return;
- }
- if (decimalp && !has_exactp) {
- /* handle decimal format as an explicit #i */
- has_exactp = true;
- exactp = false;
- }
- } else {
- if (!krational_read(K, buf, radix, &res, NULL)) {
- klispE_throw_simple_with_irritants(K, "Bad format", 1, str);
- return;
- }
- }
+ /* number wasn't a special number */
+ while (*buf == '#') {
+ switch(*++buf) {
+ case 'e': case 'E': case 'i': case 'I':
+ if (has_exactp) {
+ klispE_throw_simple_with_irritants(
+ K, "two exactness prefixes", 1, str);
+ return;
+ }
+ has_exactp = true;
+ exactp = (*buf == 'e');
+ ++buf;
+ break;
+ case 'b': case 'B': radix = 2; goto RADIX;
+ case 'o': case 'O': radix = 8; goto RADIX;
+ case 'd': case 'D': radix = 10; goto RADIX;
+ case 'x': case 'X': radix = 16; goto RADIX;
+ RADIX:
+ if (has_radixp) {
+ klispE_throw_simple_with_irritants(
+ K, "two radix prefixes", 1, str);
+ return;
+ }
+ has_radixp = true;
+ ++buf;
+ break;
+ default:
+ klispE_throw_simple_with_irritants(K, "unexpected char "
+ "after #", 1, str);
+ return;
+ }
+ }
+
+ if (radix == 10) {
+ /* only allow decimals with radix 10 */
+ bool decimalp = false;
+ if (!krational_read_decimal(K, buf, radix, &res, NULL, &decimalp)) {
+ klispE_throw_simple_with_irritants(K, "Bad format", 1, str);
+ return;
+ }
+ if (decimalp && !has_exactp) {
+ /* handle decimal format as an explicit #i */
+ has_exactp = true;
+ exactp = false;
+ }
+ } else {
+ if (!krational_read(K, buf, radix, &res, NULL)) {
+ klispE_throw_simple_with_irritants(K, "Bad format", 1, str);
+ return;
+ }
+ }
- if (has_exactp && !exactp) {
- krooted_tvs_push(K, res);
- res = kexact_to_inexact(K, res);
- krooted_tvs_pop(K);
- }
+ if (has_exactp && !exactp) {
+ krooted_tvs_push(K, res);
+ res = kexact_to_inexact(K, res);
+ krooted_tvs_pop(K);
+ }
}
kapply_cc(K, res);
}
@@ -2506,26 +2506,26 @@ void kinit_numbers_ground_env(klisp_State *K)
/* No complex or bounded reals for now */
/* 12.5.1 number?, finite?, integer? */
add_applicative(K, ground_env, "number?", ftypep, 2, symbol,
- p2tv(knumberp));
+ p2tv(knumberp));
add_applicative(K, ground_env, "finite?", ftyped_predp, 3, symbol,
- p2tv(knumber_wpvp), p2tv(kfinitep));
+ p2tv(knumber_wpvp), p2tv(kfinitep));
add_applicative(K, ground_env, "integer?", ftypep, 2, symbol,
- p2tv(kintegerp));
+ p2tv(kintegerp));
/* 12.5.? exact-integer? */
add_applicative(K, ground_env, "exact-integer?", ftypep, 2, symbol,
- p2tv(keintegerp));
+ p2tv(keintegerp));
/* 12.5.2 =? */
add_applicative(K, ground_env, "=?", ftyped_kbpredp, 3,
- symbol, p2tv(knumber_wpvp), p2tv(knum_eqp));
+ symbol, p2tv(knumber_wpvp), p2tv(knum_eqp));
/* 12.5.3 <?, <=?, >?, >=? */
add_applicative(K, ground_env, "<?", ftyped_kbpredp, 3,
- symbol, p2tv(kreal_wpvp), p2tv(knum_ltp));
+ symbol, p2tv(kreal_wpvp), p2tv(knum_ltp));
add_applicative(K, ground_env, "<=?", ftyped_kbpredp, 3,
- symbol, p2tv(kreal_wpvp), p2tv(knum_lep));
+ symbol, p2tv(kreal_wpvp), p2tv(knum_lep));
add_applicative(K, ground_env, ">?", ftyped_kbpredp, 3,
- symbol, p2tv(kreal_wpvp), p2tv(knum_gtp));
+ symbol, p2tv(kreal_wpvp), p2tv(knum_gtp));
add_applicative(K, ground_env, ">=?", ftyped_kbpredp, 3,
- symbol, p2tv(kreal_wpvp), p2tv(knum_gep));
+ symbol, p2tv(kreal_wpvp), p2tv(knum_gep));
/* 12.5.4 + */
add_applicative(K, ground_env, "+", kplus, 0);
/* 12.5.5 * */
@@ -2534,31 +2534,31 @@ void kinit_numbers_ground_env(klisp_State *K)
add_applicative(K, ground_env, "-", kminus, 0);
/* 12.5.7 zero? */
add_applicative(K, ground_env, "zero?", ftyped_predp, 3, symbol,
- p2tv(knumber_wpvp), p2tv(kzerop));
+ p2tv(knumber_wpvp), p2tv(kzerop));
/* 12.5.8 div, mod, div-and-mod */
add_applicative(K, ground_env, "div", kdiv_mod, 2, symbol,
- i2tv(FDIV_DIV));
+ i2tv(FDIV_DIV));
add_applicative(K, ground_env, "mod", kdiv_mod, 2, symbol,
- i2tv(FDIV_MOD));
+ i2tv(FDIV_MOD));
add_applicative(K, ground_env, "div-and-mod", kdiv_mod, 2, symbol,
- i2tv(FDIV_DIV | FDIV_MOD));
+ i2tv(FDIV_DIV | FDIV_MOD));
/* 12.5.9 div0, mod0, div0-and-mod0 */
add_applicative(K, ground_env, "div0", kdiv_mod, 2, symbol,
- i2tv(FDIV_ZERO | FDIV_DIV));
+ i2tv(FDIV_ZERO | FDIV_DIV));
add_applicative(K, ground_env, "mod0", kdiv_mod, 2, symbol,
- i2tv(FDIV_ZERO | FDIV_MOD));
+ i2tv(FDIV_ZERO | FDIV_MOD));
add_applicative(K, ground_env, "div0-and-mod0", kdiv_mod, 2, symbol,
- i2tv(FDIV_ZERO | FDIV_DIV | FDIV_MOD));
+ i2tv(FDIV_ZERO | FDIV_DIV | FDIV_MOD));
/* 12.5.10 positive?, negative? */
add_applicative(K, ground_env, "positive?", ftyped_predp, 3, symbol,
- p2tv(kreal_wpvp), p2tv(kpositivep));
+ p2tv(kreal_wpvp), p2tv(kpositivep));
add_applicative(K, ground_env, "negative?", ftyped_predp, 3, symbol,
- p2tv(kreal_wpvp), p2tv(knegativep));
+ p2tv(kreal_wpvp), p2tv(knegativep));
/* 12.5.11 odd?, even? */
add_applicative(K, ground_env, "odd?", ftyped_predp, 3, symbol,
- p2tv(kintegerp), p2tv(koddp));
+ p2tv(kintegerp), p2tv(koddp));
add_applicative(K, ground_env, "even?", ftyped_predp, 3, symbol,
- p2tv(kintegerp), p2tv(kevenp));
+ p2tv(kintegerp), p2tv(kevenp));
/* 12.5.12 abs */
add_applicative(K, ground_env, "abs", kabs, 0);
/* 12.5.13 min, max */
@@ -2569,23 +2569,23 @@ void kinit_numbers_ground_env(klisp_State *K)
add_applicative(K, ground_env, "lcm", klcm, 0);
/* 12.6.1 exact?, inexact?, robust?, undefined? */
add_applicative(K, ground_env, "exact?", ftyped_predp, 3, symbol,
- p2tv(knumberp), p2tv(kexactp));
+ p2tv(knumberp), p2tv(kexactp));
add_applicative(K, ground_env, "inexact?", ftyped_predp, 3, symbol,
- p2tv(knumberp), p2tv(kinexactp));
+ p2tv(knumberp), p2tv(kinexactp));
add_applicative(K, ground_env, "robust?", ftyped_predp, 3, symbol,
- p2tv(knumberp), p2tv(krobustp));
+ p2tv(knumberp), p2tv(krobustp));
add_applicative(K, ground_env, "undefined?", ftyped_predp, 3, symbol,
- p2tv(knumberp), p2tv(kundefinedp));
+ p2tv(knumberp), p2tv(kundefinedp));
/* 12.6.2 get-real-internal-bounds, get-real-exact-bounds */
add_applicative(K, ground_env, "get-real-internal-bounds",
- kget_real_internal_bounds, 0);
+ kget_real_internal_bounds, 0);
add_applicative(K, ground_env, "get-real-exact-bounds",
- kget_real_exact_bounds, 0);
+ kget_real_exact_bounds, 0);
/* 12.6.3 get-real-internal-primary, get-real-exact-primary */
add_applicative(K, ground_env, "get-real-internal-primary",
- kget_real_internal_primary, 0);
+ kget_real_internal_primary, 0);
add_applicative(K, ground_env, "get-real-exact-primary",
- kget_real_exact_primary, 0);
+ kget_real_exact_primary, 0);
/* 12.6.4 make-inexact */
add_applicative(K, ground_env, "make-inexact", kmake_inexact, 0);
/* 12.6.5 real->inexact, real->exact */
@@ -2593,12 +2593,12 @@ void kinit_numbers_ground_env(klisp_State *K)
add_applicative(K, ground_env, "real->exact", kreal_to_exact, 0);
/* 12.6.6 with-strict-arithmetic, get-strict-arithmetic? */
add_applicative(K, ground_env, "with-strict-arithmetic",
- kwith_strict_arithmetic, 0);
+ kwith_strict_arithmetic, 0);
add_applicative(K, ground_env, "get-strict-arithmetic?",
- kget_strict_arithmeticp, 0);
+ kget_strict_arithmeticp, 0);
/* 12.8.1 rational? */
add_applicative(K, ground_env, "rational?", ftypep, 2, symbol,
- p2tv(krationalp));
+ p2tv(krationalp));
/* 12.8.2 / */
add_applicative(K, ground_env, "/", kdivided, 0);
/* 12.8.3 numerator, denominator */
@@ -2606,19 +2606,19 @@ void kinit_numbers_ground_env(klisp_State *K)
add_applicative(K, ground_env, "denominator", kdenominator, 0);
/* 12.8.4 floor, ceiling, truncate, round */
add_applicative(K, ground_env, "floor", kreal_to_integer, 2,
- symbol, i2tv((int32_t) K_FLOOR));
+ symbol, i2tv((int32_t) K_FLOOR));
add_applicative(K, ground_env, "ceiling", kreal_to_integer, 2,
- symbol, i2tv((int32_t) K_CEILING));
+ symbol, i2tv((int32_t) K_CEILING));
add_applicative(K, ground_env, "truncate", kreal_to_integer, 2,
- symbol, i2tv((int32_t) K_TRUNCATE));
+ symbol, i2tv((int32_t) K_TRUNCATE));
add_applicative(K, ground_env, "round", kreal_to_integer, 2,
- symbol, i2tv((int32_t) K_ROUND_EVEN));
+ symbol, i2tv((int32_t) K_ROUND_EVEN));
/* 12.8.5 rationalize, simplest-rational */
add_applicative(K, ground_env, "rationalize", krationalize, 0);
add_applicative(K, ground_env, "simplest-rational", ksimplest_rational, 0);
/* 12.9.1 real? */
add_applicative(K, ground_env, "real?", ftypep, 2, symbol,
- p2tv(krealp));
+ p2tv(krealp));
/* 12.9.2 exp, log */
add_applicative(K, ground_env, "exp", kexp, 0);
add_applicative(K, ground_env, "log", klog, 0);
diff --git a/src/kgpair_mut.c b/src/kgpair_mut.c
@@ -30,7 +30,7 @@ void set_carB(klisp_State *K)
(void) denv;
(void) xparams;
bind_2tp(K, ptree, "pair", ttispair, pair,
- "any", anytype, new_car);
+ "any", anytype, new_car);
if(!kis_mutable(pair)) {
klispE_throw_simple(K, "immutable pair");
@@ -49,7 +49,7 @@ void set_cdrB(klisp_State *K)
(void) denv;
(void) xparams;
bind_2tp(K, ptree, "pair", ttispair, pair,
- "any", anytype, new_cdr);
+ "any", anytype, new_cdr);
if(!kis_mutable(pair)) {
klispE_throw_simple(K, "immutable pair");
@@ -100,19 +100,19 @@ void encycleB(klisp_State *K)
UNUSED(xparams);
bind_3tp(K, ptree, "any", anytype, obj,
- "exact integer", keintegerp, tk1,
- "exact integer", keintegerp, tk2);
+ "exact integer", keintegerp, tk1,
+ "exact integer", keintegerp, tk2);
if (knegativep(tk1) || knegativep(tk2)) {
- klispE_throw_simple(K, "negative index");
- return;
+ klispE_throw_simple(K, "negative index");
+ return;
}
if (!ttisfixint(tk1) || !ttisfixint(tk2)) {
- /* no list can have that many pairs */
- klispE_throw_simple(K, "non pair found while traversing "
- "object");
- return;
+ /* no list can have that many pairs */
+ klispE_throw_simple(K, "non pair found while traversing "
+ "object");
+ return;
}
int32_t k1 = ivalue(tk1);
@@ -121,19 +121,19 @@ void encycleB(klisp_State *K)
TValue tail = obj;
while(k1 != 0) {
- if (!ttispair(tail)) {
- unmark_list(K, obj);
- klispE_throw_simple(K, "non pair found while traversing "
- "object");
- return;
- } else if (kis_marked(tail)) {
- unmark_list(K, obj);
- klispE_throw_simple(K, "too few pairs in cyclic list");
- return;
- }
- kmark(tail);
- tail = kcdr(tail);
- --k1;
+ if (!ttispair(tail)) {
+ unmark_list(K, obj);
+ klispE_throw_simple(K, "non pair found while traversing "
+ "object");
+ return;
+ } else if (kis_marked(tail)) {
+ unmark_list(K, obj);
+ klispE_throw_simple(K, "too few pairs in cyclic list");
+ return;
+ }
+ kmark(tail);
+ tail = kcdr(tail);
+ --k1;
}
TValue fcp = tail;
@@ -141,40 +141,40 @@ void encycleB(klisp_State *K)
/* if k2 == 0 do nothing (but this still checks that the obj
has at least k1 pairs */
if (k2 != 0) {
- --k2; /* to have cycle length k2 we should discard k2-1 pairs */
- /* REFACTOR: should probably refactor this to avoid the
- duplicated checks */
- while(k2 != 0) {
- if (!ttispair(tail)) {
- unmark_list(K, obj);
- klispE_throw_simple(K, "non pair found while traversing "
- "object");
- return;
- } else if (kis_marked(tail)) {
- unmark_list(K, obj);
- klispE_throw_simple(K, "too few pairs in cyclic list");
- return;
- }
- kmark(tail);
- tail = kcdr(tail);
- --k2;
- }
- if (!ttispair(tail)) {
- unmark_list(K, obj);
- klispE_throw_simple(K, "non pair found while traversing "
- "object");
- return;
- } else if (kis_marked(tail)) {
- unmark_list(K, obj);
- klispE_throw_simple(K, "too few pairs in cyclic list");
- return;
- } else if (!kis_mutable(tail)) {
- unmark_list(K, obj);
- klispE_throw_simple(K, "immutable pair");
- return;
- } else {
- kset_cdr(tail, fcp);
- }
+ --k2; /* to have cycle length k2 we should discard k2-1 pairs */
+ /* REFACTOR: should probably refactor this to avoid the
+ duplicated checks */
+ while(k2 != 0) {
+ if (!ttispair(tail)) {
+ unmark_list(K, obj);
+ klispE_throw_simple(K, "non pair found while traversing "
+ "object");
+ return;
+ } else if (kis_marked(tail)) {
+ unmark_list(K, obj);
+ klispE_throw_simple(K, "too few pairs in cyclic list");
+ return;
+ }
+ kmark(tail);
+ tail = kcdr(tail);
+ --k2;
+ }
+ if (!ttispair(tail)) {
+ unmark_list(K, obj);
+ klispE_throw_simple(K, "non pair found while traversing "
+ "object");
+ return;
+ } else if (kis_marked(tail)) {
+ unmark_list(K, obj);
+ klispE_throw_simple(K, "too few pairs in cyclic list");
+ return;
+ } else if (!kis_mutable(tail)) {
+ unmark_list(K, obj);
+ klispE_throw_simple(K, "immutable pair");
+ return;
+ } else {
+ kset_cdr(tail, fcp);
+ }
}
unmark_list(K, obj);
kapply_cc(K, KINERT);
@@ -193,36 +193,36 @@ void list_setB(klisp_State *K)
UNUSED(xparams);
bind_3tp(K, ptree, "any", anytype, obj,
- "exact integer", keintegerp, tk,
- "any", anytype, val);
+ "exact integer", keintegerp, tk,
+ "any", anytype, val);
if (knegativep(tk)) {
- klispE_throw_simple(K, "negative index");
- return;
+ klispE_throw_simple(K, "negative index");
+ return;
}
int32_t k = (ttisfixint(tk))? ivalue(tk)
- : ksmallest_index(K, obj, tk);
+ : ksmallest_index(K, obj, tk);
while(k) {
- if (!ttispair(obj)) {
- klispE_throw_simple(K, "non pair found while traversing "
- "object");
- return;
- }
- obj = kcdr(obj);
- --k;
+ if (!ttispair(obj)) {
+ klispE_throw_simple(K, "non pair found while traversing "
+ "object");
+ return;
+ }
+ obj = kcdr(obj);
+ --k;
}
if (!ttispair(obj)) {
- klispE_throw_simple(K, "non pair found while traversing "
- "object");
+ klispE_throw_simple(K, "non pair found while traversing "
+ "object");
} else if (kis_immutable(obj)) {
- /* this could be checked before, but the error here seems better */
- klispE_throw_simple(K, "immutable pair");
+ /* this could be checked before, but the error here seems better */
+ klispE_throw_simple(K, "immutable pair");
} else {
- kset_car(obj, val);
- kapply_cc(K, KINERT);
+ kset_car(obj, val);
+ kapply_cc(K, KINERT);
}
}
@@ -231,9 +231,9 @@ inline void appendB_clear_last_pairs(klisp_State *K, TValue ls)
{
UNUSED(K);
while(ttispair(ls) && kis_marked(ls)) {
- TValue first = ls;
- ls = kget_mark(ls);
- kunmark(first);
+ TValue first = ls;
+ ls = kget_mark(ls);
+ kunmark(first);
}
}
@@ -244,7 +244,7 @@ inline void appendB_clear_last_pairs(klisp_State *K, TValue ls)
/* GC: Assumes lss is rooted */
TValue appendB_get_lss_endpoints(klisp_State *K, TValue lss, int32_t apairs,
- int32_t cpairs)
+ int32_t cpairs)
{
TValue elist = kcons(K, KNIL, KNIL);
krooted_vars_push(K, &elist);
@@ -255,126 +255,126 @@ TValue appendB_get_lss_endpoints(klisp_State *K, TValue lss, int32_t apairs,
TValue last_apair = KNIL;
while(apairs != 0 || cpairs != 0) {
- int32_t pairs;
+ int32_t pairs;
- if (apairs == 0) {
- /* this is the first run of the loop (if there is no acyclic part)
- or the second run of the loop (the cyclic part),
- must remember the last acyclic pair to encycle! the result */
- last_apair = last_pair;
- pairs = cpairs;
- } else {
- /* this is the first (maybe only) run of the loop
- (the acyclic part) */
- pairs = apairs;
- }
-
- while(pairs--) {
- TValue first = kcar(tail);
- tail = kcdr(tail);
-
- /* skip over non final nils, but final nil
- should be added as last pair to let the result
- be even */
- if (ttisnil(first)) {
- if (ttisnil(tail)) {
- kset_cdr(last_pair, kcons(K, first, KNIL));
- }
- continue;
- }
-
- TValue ftail = first;
- TValue flastp = first;
-
- /* find the last pair to check the object */
- while(ttispair(ftail) && !kis_marked(ftail)) {
- kmark(ftail);
- flastp = ftail; /* remember last pair */
- ftail = kcdr(ftail);
- }
+ if (apairs == 0) {
+ /* this is the first run of the loop (if there is no acyclic part)
+ or the second run of the loop (the cyclic part),
+ must remember the last acyclic pair to encycle! the result */
+ last_apair = last_pair;
+ pairs = cpairs;
+ } else {
+ /* this is the first (maybe only) run of the loop
+ (the acyclic part) */
+ pairs = apairs;
+ }
+
+ while(pairs--) {
+ TValue first = kcar(tail);
+ tail = kcdr(tail);
+
+ /* skip over non final nils, but final nil
+ should be added as last pair to let the result
+ be even */
+ if (ttisnil(first)) {
+ if (ttisnil(tail)) {
+ kset_cdr(last_pair, kcons(K, first, KNIL));
+ }
+ continue;
+ }
+
+ TValue ftail = first;
+ TValue flastp = first;
+
+ /* find the last pair to check the object */
+ while(ttispair(ftail) && !kis_marked(ftail)) {
+ kmark(ftail);
+ flastp = ftail; /* remember last pair */
+ ftail = kcdr(ftail);
+ }
- /* can't unmark the list till the errors are checked,
- otherwise the unmarking may be incorrect */
- if (ttisnil(tail)) {
- /* last argument has special treatment */
- if (ttispair(ftail) && ttisnil(kcdr(ftail))) {
- /* repeated last pair, this is the only check
- that is done on the last argument */
- appendB_clear_last_pairs(K, last_pairs);
- unmark_list(K, first);
- klispE_throw_simple(K, "repeated last pairs");
- return KINERT;
- } else {
- unmark_list(K, first);
- /* add last object to the endpoints list, don't add
- its last pair */
- kset_cdr(last_pair, kcons(K, first, KNIL));
- }
- } else { /* non final argument, must be an acyclic list
- with unique, mutable last pair */
- if (ttisnil(ftail)) {
- /* acyclic list with non repeated last pair,
- check mutability */
- unmark_list(K, first);
- if (kis_immutable(flastp)) {
- appendB_clear_last_pairs(K, last_pairs);
- klispE_throw_simple(K, "immutable pair found");
- return KINERT;
- }
- /* add the last pair to the list of last pairs */
- kset_mark(flastp, last_pairs);
- last_pairs = flastp;
+ /* can't unmark the list till the errors are checked,
+ otherwise the unmarking may be incorrect */
+ if (ttisnil(tail)) {
+ /* last argument has special treatment */
+ if (ttispair(ftail) && ttisnil(kcdr(ftail))) {
+ /* repeated last pair, this is the only check
+ that is done on the last argument */
+ appendB_clear_last_pairs(K, last_pairs);
+ unmark_list(K, first);
+ klispE_throw_simple(K, "repeated last pairs");
+ return KINERT;
+ } else {
+ unmark_list(K, first);
+ /* add last object to the endpoints list, don't add
+ its last pair */
+ kset_cdr(last_pair, kcons(K, first, KNIL));
+ }
+ } else { /* non final argument, must be an acyclic list
+ with unique, mutable last pair */
+ if (ttisnil(ftail)) {
+ /* acyclic list with non repeated last pair,
+ check mutability */
+ unmark_list(K, first);
+ if (kis_immutable(flastp)) {
+ appendB_clear_last_pairs(K, last_pairs);
+ klispE_throw_simple(K, "immutable pair found");
+ return KINERT;
+ }
+ /* add the last pair to the list of last pairs */
+ kset_mark(flastp, last_pairs);
+ last_pairs = flastp;
- /* add both the first and last pair to the endpoints
- list */
- TValue new_pair = kcons(K, first, KNIL);
- kset_cdr(last_pair, new_pair);
- last_pair = new_pair;
- new_pair = kcons(K, flastp, KNIL);
- kset_cdr(last_pair, new_pair);
- last_pair = new_pair;
- } else {
- /* impoper list or repeated last pair or cyclic list */
- appendB_clear_last_pairs(K, last_pairs);
- unmark_list(K, first);
-
- if (ttispair(ftail)) {
- if (ttisnil(kcdr(ftail))) {
- klispE_throw_simple(K, "repeated last pairs");
- } else {
- klispE_throw_simple(K, "cyclic list as non last "
- "argument");
- }
- } else {
- klispE_throw_simple(K, "improper list as non last "
- "argument");
- }
- return KINERT;
- }
- }
- }
- if (apairs != 0) {
- /* acyclic part done */
- apairs = 0;
- } else {
- /* cyclic part done, program encycle if necessary */
- cpairs = 0;
- if (!tv_equal(last_apair, last_pair)) {
- TValue first_cpair = kcadr(last_apair);
- kset_cdr(last_pair, kcons(K, first_cpair, KNIL));
- } else {
- /* all elements of the cycle are (), add extra
- nil to simplify the code setting the cdrs */
- kset_cdr(last_pair, kcons(K, KNIL, KNIL));
- }
- }
+ /* add both the first and last pair to the endpoints
+ list */
+ TValue new_pair = kcons(K, first, KNIL);
+ kset_cdr(last_pair, new_pair);
+ last_pair = new_pair;
+ new_pair = kcons(K, flastp, KNIL);
+ kset_cdr(last_pair, new_pair);
+ last_pair = new_pair;
+ } else {
+ /* impoper list or repeated last pair or cyclic list */
+ appendB_clear_last_pairs(K, last_pairs);
+ unmark_list(K, first);
+
+ if (ttispair(ftail)) {
+ if (ttisnil(kcdr(ftail))) {
+ klispE_throw_simple(K, "repeated last pairs");
+ } else {
+ klispE_throw_simple(K, "cyclic list as non last "
+ "argument");
+ }
+ } else {
+ klispE_throw_simple(K, "improper list as non last "
+ "argument");
+ }
+ return KINERT;
+ }
+ }
+ }
+ if (apairs != 0) {
+ /* acyclic part done */
+ apairs = 0;
+ } else {
+ /* cyclic part done, program encycle if necessary */
+ cpairs = 0;
+ if (!tv_equal(last_apair, last_pair)) {
+ TValue first_cpair = kcadr(last_apair);
+ kset_cdr(last_pair, kcons(K, first_cpair, KNIL));
+ } else {
+ /* all elements of the cycle are (), add extra
+ nil to simplify the code setting the cdrs */
+ kset_cdr(last_pair, kcons(K, KNIL, KNIL));
+ }
+ }
}
appendB_clear_last_pairs(K, last_pairs);
/* discard the first element (there is always one) because it
- isn't necessary, the list is used to set the last pairs of
- the objects to the correspoding next first pair */
+ isn't necessary, the list is used to set the last pairs of
+ the objects to the correspoding next first pair */
krooted_vars_pop(K);
return kcdr(kcdr(elist));
}
@@ -389,34 +389,34 @@ void appendB(klisp_State *K)
UNUSED(xparams);
UNUSED(denv);
if (ttisnil(ptree)) {
- klispE_throw_simple(K, "no lists");
- return;
+ klispE_throw_simple(K, "no lists");
+ return;
} else if (!ttispair(ptree)) {
- klispE_throw_simple(K, "bad ptree");
- return;
+ klispE_throw_simple(K, "bad ptree");
+ return;
} else if (ttisnil(kcar(ptree))) {
- klispE_throw_simple(K, "empty first list");
- return;
+ klispE_throw_simple(K, "empty first list");
+ return;
}
TValue lss = ptree;
TValue first_ls = kcar(lss);
int32_t pairs, cpairs;
/* ASK John: if encycle! has only one argument, can't it be cyclic?
- the report says no, but the wording is poor */
+ the report says no, but the wording is poor */
check_list(K, false, first_ls, NULL, NULL);
check_list(K, true, lss, &pairs, &cpairs);
int32_t apairs = pairs - cpairs;
TValue endpoints =
- appendB_get_lss_endpoints(K, lss, apairs, cpairs);
+ appendB_get_lss_endpoints(K, lss, apairs, cpairs);
/* connect all the last pairs to the corresponding next first pair,
- endpoints is even */
+ endpoints is even */
while(!ttisnil(endpoints)) {
- TValue first = kcar(endpoints);
- endpoints = kcdr(endpoints);
- TValue second = kcar(endpoints);
- endpoints = kcdr(endpoints);
- kset_cdr(first, second);
+ TValue first = kcar(endpoints);
+ endpoints = kcdr(endpoints);
+ TValue second = kcar(endpoints);
+ endpoints = kcdr(endpoints);
+ kset_cdr(first, second);
}
kapply_cc(K, KINERT);
}
@@ -442,12 +442,12 @@ void assq(klisp_State *K)
TValue tail = ls;
TValue res = KNIL;
while(pairs--) {
- TValue first = kcar(tail);
- if (eq2p(K, kcar(first), obj)) {
- res = first;
- break;
- }
- tail = kcdr(tail);
+ TValue first = kcar(tail);
+ if (eq2p(K, kcar(first), obj)) {
+ res = first;
+ break;
+ }
+ tail = kcdr(tail);
}
kapply_cc(K, res);
@@ -471,12 +471,12 @@ void memqp(klisp_State *K)
TValue tail = ls;
TValue res = KFALSE;
while(pairs--) {
- TValue first = kcar(tail);
- if (eq2p(K, first, obj)) {
- res = KTRUE;
- break;
- }
- tail = kcdr(tail);
+ TValue first = kcar(tail);
+ if (eq2p(K, first, obj)) {
+ res = KTRUE;
+ break;
+ }
+ tail = kcdr(tail);
}
kapply_cc(K, res);
@@ -496,7 +496,7 @@ void kinit_pair_mut_ground_env(klisp_State *K)
add_applicative(K, ground_env, "set-cdr!", set_cdrB, 0);
/* 4.7.2 copy-es-immutable */
add_applicative(K, ground_env, "copy-es-immutable", copy_es, 2, symbol,
- b2tv(false));
+ b2tv(false));
/* 5.8.1 encycle! */
add_applicative(K, ground_env, "encycle!", encycleB, 0);
/* 6.?? list-set! */
@@ -511,7 +511,7 @@ void kinit_pair_mut_ground_env(klisp_State *K)
add_applicative(K, ground_env, "memq?", memqp, 0);
/* ?.? immutable-pair?, mutable-pair? */
add_applicative(K, ground_env, "immutable-pair?", ftypep, 2, symbol,
- p2tv(kimmutable_pairp));
+ p2tv(kimmutable_pairp));
add_applicative(K, ground_env, "mutable-pair?", ftypep, 2, symbol,
- p2tv(kmutable_pairp));
+ p2tv(kmutable_pairp));
}
diff --git a/src/kgpairs_lists.c b/src/kgpairs_lists.c
@@ -79,8 +79,8 @@ void listS(klisp_State *K)
UNUSED(denv);
if (ttisnil(ptree)) {
- klispE_throw_simple(K, "empty argument list");
- return;
+ klispE_throw_simple(K, "empty argument list");
+ return;
}
TValue res_obj = kcons(K, KNIL, KNIL);
krooted_vars_push(K, &res_obj);
@@ -89,41 +89,41 @@ void listS(klisp_State *K)
/* First copy the list, but remembering the next to last pair */
while(ttispair(tail) && !kis_marked(tail)) {
- kmark(tail);
- /* we save the next_to last pair in the cdr to
- allow the change into an improper list later */
- TValue new_pair = kcons(K, kcar(tail), last_pair);
- kset_cdr(last_pair, new_pair);
- last_pair = new_pair;
- tail = kcdr(tail);
+ kmark(tail);
+ /* we save the next_to last pair in the cdr to
+ allow the change into an improper list later */
+ TValue new_pair = kcons(K, kcar(tail), last_pair);
+ kset_cdr(last_pair, new_pair);
+ last_pair = new_pair;
+ tail = kcdr(tail);
}
unmark_list(K, ptree);
if (ttisnil(tail)) {
- /* Now eliminate the last pair to get the correct improper list.
- This avoids an if in the above loop. It's inside the if because
- we need at least one pair for this to work. */
- TValue next_to_last_pair = kcdr(last_pair);
- kset_cdr(next_to_last_pair, kcar(last_pair));
- krooted_vars_pop(K);
- kapply_cc(K, kcdr(res_obj));
+ /* Now eliminate the last pair to get the correct improper list.
+ This avoids an if in the above loop. It's inside the if because
+ we need at least one pair for this to work. */
+ TValue next_to_last_pair = kcdr(last_pair);
+ kset_cdr(next_to_last_pair, kcar(last_pair));
+ krooted_vars_pop(K);
+ kapply_cc(K, kcdr(res_obj));
} else if (ttispair(tail)) { /* cyclic argument list */
- klispE_throw_simple(K, "cyclic argument list");
- return;
+ klispE_throw_simple(K, "cyclic argument list");
+ return;
} else {
- klispE_throw_simple(K, "argument list is improper");
- return;
+ klispE_throw_simple(K, "argument list is improper");
+ return;
}
}
/* Helper macros to construct xparams[1] for c[ad]{1,4}r */
-#define C_AD_R_PARAM(len_, br_) \
+#define C_AD_R_PARAM(len_, br_) \
(i2tv((C_AD_R_LEN(len_) | (C_AD_R_BRANCH(br_)))))
#define C_AD_R_LEN(len_) ((len_) << 4)
-#define C_AD_R_BRANCH(br_) \
- ((br_ & 0x0001? 0x1 : 0) | \
- (br_ & 0x0010? 0x2 : 0) | \
- (br_ & 0x0100? 0x4 : 0) | \
+#define C_AD_R_BRANCH(br_) \
+ ((br_ & 0x0001? 0x1 : 0) | \
+ (br_ & 0x0010? 0x2 : 0) | \
+ (br_ & 0x0100? 0x4 : 0) | \
(br_ & 0x1000? 0x8 : 0))
/* 5.4.1 car, cdr */
@@ -140,14 +140,14 @@ void c_ad_r(klisp_State *K)
/*
** xparams[0]: name as symbol
** xparams[1]: an int with the less significant 2 nibbles
- ** standing for the count and the branch selection.
- ** The high nibble is the count: that is the number of
- ** 'a's and 'd's in the name, for example:
- ** 0x1? for car and cdr.
- ** 0x2? for caar, cadr, cdar and cddr.
- ** The low nibble is the branch selection, a 0 bit means
- ** car, a 1 bit means cdr, the first bit to be applied
- ** is bit 0 so: caar=0x20, cadr=0x21, cdar:0x22, cddr 0x23
+ ** standing for the count and the branch selection.
+ ** The high nibble is the count: that is the number of
+ ** 'a's and 'd's in the name, for example:
+ ** 0x1? for car and cdr.
+ ** 0x2? for caar, cadr, cdar and cddr.
+ ** The low nibble is the branch selection, a 0 bit means
+ ** car, a 1 bit means cdr, the first bit to be applied
+ ** is bit 0 so: caar=0x20, cadr=0x21, cdar:0x22, cddr 0x23
*/
int p = ivalue(xparams[1]);
@@ -157,13 +157,13 @@ void c_ad_r(klisp_State *K)
bind_1p(K, ptree, obj);
while(count) {
- if (!ttispair(obj)) {
- klispE_throw_simple(K, "non pair found while traversing");
- return;
- }
- obj = ((branches & 1) == 0)? kcar(obj) : kcdr(obj);
- branches >>= 1;
- --count;
+ if (!ttispair(obj)) {
+ klispE_throw_simple(K, "non pair found while traversing");
+ return;
+ }
+ obj = ((branches & 1) == 0)? kcar(obj) : kcdr(obj);
+ branches >>= 1;
+ --count;
}
kapply_cc(K, obj);
}
@@ -195,7 +195,7 @@ void make_list(klisp_State *K)
int i = ivalue(tv_s);
krooted_vars_push(K, &tail);
while(i-- > 0) {
- tail = kcons(K, fill, tail);
+ tail = kcons(K, fill, tail);
}
krooted_vars_pop(K);
@@ -234,19 +234,19 @@ void reverse(klisp_State *K)
TValue res = KNIL;
krooted_vars_push(K, &res);
while(ttispair(tail) && !kis_marked(tail)) {
- kmark(tail);
- res = kcons(K, kcar(tail), res);
- tail = kcdr(tail);
+ kmark(tail);
+ res = kcons(K, kcar(tail), res);
+ tail = kcdr(tail);
}
unmark_list(K, ls);
krooted_vars_pop(K);
if (ttispair(tail)) {
- klispE_throw_simple(K, "expected acyclic list");
+ klispE_throw_simple(K, "expected acyclic list");
} else if (!ttisnil(tail)) {
- klispE_throw_simple(K, "expected list");
+ klispE_throw_simple(K, "expected list");
} else {
- kapply_cc(K, res);
+ kapply_cc(K, res);
}
}
@@ -266,7 +266,7 @@ void get_list_metrics(klisp_State *K)
get_list_metrics_aux(K, obj, &pairs, &nils, &apairs, &cpairs);
TValue res = klist(K, 4, i2tv(pairs), i2tv(nils),
- i2tv(apairs), i2tv(cpairs));
+ i2tv(apairs), i2tv(cpairs));
kapply_cc(K, res);
}
@@ -283,24 +283,24 @@ void list_tail(klisp_State *K)
UNUSED(xparams);
UNUSED(denv);
bind_2tp(K, ptree, "any", anytype, obj,
- "exact integer", keintegerp, tk);
+ "exact integer", keintegerp, tk);
if (knegativep(tk)) {
- klispE_throw_simple(K, "negative index");
- return;
+ klispE_throw_simple(K, "negative index");
+ return;
}
int32_t k = (ttisfixint(tk))? ivalue(tk)
- : ksmallest_index(K, obj, tk);
+ : ksmallest_index(K, obj, tk);
while(k) {
- if (!ttispair(obj)) {
- klispE_throw_simple(K, "non pair found while traversing "
- "object");
- return;
- }
- obj = kcdr(obj);
- --k;
+ if (!ttispair(obj)) {
+ klispE_throw_simple(K, "non pair found while traversing "
+ "object");
+ return;
+ }
+ obj = kcdr(obj);
+ --k;
}
kapply_cc(K, obj);
}
@@ -320,9 +320,9 @@ void length(klisp_State *K)
TValue tail = obj;
int pairs = 0;
while(ttispair(tail) && !kis_marked(tail)) {
- kmark(tail);
- tail = kcdr(tail);
- ++pairs;
+ kmark(tail);
+ tail = kcdr(tail);
+ ++pairs;
}
unmark_list(K, obj);
@@ -344,29 +344,29 @@ void list_ref(klisp_State *K)
UNUSED(xparams);
bind_2tp(K, ptree, "any", anytype, obj,
- "exact integer", keintegerp, tk);
+ "exact integer", keintegerp, tk);
if (knegativep(tk)) {
- klispE_throw_simple(K, "negative index");
- return;
+ klispE_throw_simple(K, "negative index");
+ return;
}
int32_t k = (ttisfixint(tk))? ivalue(tk)
- : ksmallest_index(K, obj, tk);
+ : ksmallest_index(K, obj, tk);
while(k) {
- if (!ttispair(obj)) {
- klispE_throw_simple(K, "non pair found while traversing "
- "object");
- return;
- }
- obj = kcdr(obj);
- --k;
+ if (!ttispair(obj)) {
+ klispE_throw_simple(K, "non pair found while traversing "
+ "object");
+ return;
+ }
+ obj = kcdr(obj);
+ --k;
}
if (!ttispair(obj)) {
- klispE_throw_simple(K, "non pair found while traversing "
- "object");
- return;
+ klispE_throw_simple(K, "non pair found while traversing "
+ "object");
+ return;
}
TValue res = kcar(obj);
kapply_cc(K, res);
@@ -380,11 +380,11 @@ void list_ref(klisp_State *K)
/* GC: Assumes obj is rooted */
TValue append_check_copy_list(klisp_State *K, char *name, TValue obj,
- TValue *last_pair_ptr)
+ TValue *last_pair_ptr)
{
/* return early if nil to avoid setting *last_pair_ptr */
if (ttisnil(obj))
- return obj;
+ return obj;
TValue copy = kcons(K, KNIL, KNIL);
krooted_vars_push(K, ©);
@@ -392,20 +392,20 @@ TValue append_check_copy_list(klisp_State *K, char *name, TValue obj,
TValue tail = obj;
while(ttispair(tail) && !kis_marked(tail)) {
- kmark(tail);
- TValue new_pair = kcons(K, kcar(tail), KNIL);
- kset_cdr(last_pair, new_pair);
- last_pair = new_pair;
- tail = kcdr(tail);
+ kmark(tail);
+ TValue new_pair = kcons(K, kcar(tail), KNIL);
+ kset_cdr(last_pair, new_pair);
+ last_pair = new_pair;
+ tail = kcdr(tail);
}
unmark_list(K, obj);
if (ttispair(tail)) {
- klispE_throw_simple(K, "expected acyclic list");
- return KINERT;
+ klispE_throw_simple(K, "expected acyclic list");
+ return KINERT;
} else if (!ttisnil(tail)) {
- klispE_throw_simple(K, "expected list");
- return KINERT;
+ klispE_throw_simple(K, "expected list");
+ return KINERT;
}
*last_pair_ptr = last_pair;
krooted_vars_pop(K);
@@ -433,48 +433,48 @@ void append(klisp_State *K)
TValue last_apair;
while (apairs != 0 || cpairs != 0) {
- if (apairs == 0) {
- /* this is the first run of the loop (if there is no acyclic part)
- or the second run of the loop (the cyclic part),
- must remember the last acyclic pair to encycle! the result */
- last_apair = last_pair;
- pairs = cpairs;
- } else {
- /* this is the first (maybe only) run of the loop
- (the acyclic part) */
- pairs = apairs;
- }
-
- while (pairs--) {
- TValue first = kcar(lss);
- lss = kcdr(lss);
- TValue next_list;
- TValue new_last_pair = last_pair; /* this helps if first is nil */
- /* don't check or copy last list */
- if (ttisnil(lss)) {
- /* here, new_last_pair is bogus, but it isn't necessary
- anymore so don't set it */
- next_list = first;
- } else {
- next_list = append_check_copy_list(K, "append", first,
- &new_last_pair);
- }
- kset_cdr(last_pair, next_list);
- last_pair = new_last_pair;
- }
-
- if (apairs != 0) {
- /* acyclic part done */
- apairs = 0;
- } else {
- /* cyclic part done */
- cpairs = 0;
- TValue first_cpair = kcdr(last_apair);
- TValue last_cpair = last_pair;
- /* this works even if there is no cycle to be formed
- (kcdr(last_apair) == ()) */
- kset_cdr(last_cpair, first_cpair); /* encycle! */
- }
+ if (apairs == 0) {
+ /* this is the first run of the loop (if there is no acyclic part)
+ or the second run of the loop (the cyclic part),
+ must remember the last acyclic pair to encycle! the result */
+ last_apair = last_pair;
+ pairs = cpairs;
+ } else {
+ /* this is the first (maybe only) run of the loop
+ (the acyclic part) */
+ pairs = apairs;
+ }
+
+ while (pairs--) {
+ TValue first = kcar(lss);
+ lss = kcdr(lss);
+ TValue next_list;
+ TValue new_last_pair = last_pair; /* this helps if first is nil */
+ /* don't check or copy last list */
+ if (ttisnil(lss)) {
+ /* here, new_last_pair is bogus, but it isn't necessary
+ anymore so don't set it */
+ next_list = first;
+ } else {
+ next_list = append_check_copy_list(K, "append", first,
+ &new_last_pair);
+ }
+ kset_cdr(last_pair, next_list);
+ last_pair = new_last_pair;
+ }
+
+ if (apairs != 0) {
+ /* acyclic part done */
+ apairs = 0;
+ } else {
+ /* cyclic part done */
+ cpairs = 0;
+ TValue first_cpair = kcdr(last_apair);
+ TValue last_cpair = last_pair;
+ /* this works even if there is no cycle to be formed
+ (kcdr(last_apair) == ()) */
+ kset_cdr(last_cpair, first_cpair); /* encycle! */
+ }
}
krooted_vars_pop(K);
kapply_cc(K, kcdr(res_list));
@@ -504,30 +504,30 @@ void list_neighbors(klisp_State *K)
bool doing_cycle = false;
while(count > 0 || !doing_cycle) {
- while(count-- > 0) { /* can be -1 if ls is nil */
- TValue first = kcar(tail);
- tail = kcdr(tail); /* tail advances one place per iter */
- TValue new_car = klist(K, 2, first, kcar(tail));
- krooted_tvs_push(K, new_car);
- TValue new_pair = kcons(K, new_car, KNIL);
- krooted_tvs_pop(K);
- kset_cdr(last_pair, new_pair);
- last_pair = new_pair;
- }
-
- if (doing_cycle) {
- TValue first_cpair = kcdr(last_apair);
- kset_cdr(last_pair, first_cpair);
- } else { /* this is done even if cpairs is 0 to terminate the loop */
- doing_cycle = true;
- /* must remember first cycle pair to reconstruct the cycle,
- we can save the last outside of the cycle and then check
- its cdr */
- last_apair = last_pair;
- count = cpairs; /* this contains the sublist that has the last
- and first element of the cycle */
- /* this will loop once more */
- }
+ while(count-- > 0) { /* can be -1 if ls is nil */
+ TValue first = kcar(tail);
+ tail = kcdr(tail); /* tail advances one place per iter */
+ TValue new_car = klist(K, 2, first, kcar(tail));
+ krooted_tvs_push(K, new_car);
+ TValue new_pair = kcons(K, new_car, KNIL);
+ krooted_tvs_pop(K);
+ kset_cdr(last_pair, new_pair);
+ last_pair = new_pair;
+ }
+
+ if (doing_cycle) {
+ TValue first_cpair = kcdr(last_apair);
+ kset_cdr(last_pair, first_cpair);
+ } else { /* this is done even if cpairs is 0 to terminate the loop */
+ doing_cycle = true;
+ /* must remember first cycle pair to reconstruct the cycle,
+ we can save the last outside of the cycle and then check
+ its cdr */
+ last_apair = last_pair;
+ count = cpairs; /* this contains the sublist that has the last
+ and first element of the cycle */
+ /* this will loop once more */
+ }
}
krooted_vars_pop(K);
kapply_cc(K, kcdr(neighbors));
@@ -571,14 +571,14 @@ void do_filter_encycle(klisp_State *K)
TValue last_non_cycle_pair = xparams[1];
if (tv_equal(last_pair, last_non_cycle_pair)) {
- /* no cycle in result, this isn't strictly necessary
- but just in case */
- kset_cdr(last_non_cycle_pair, KNIL);
+ /* no cycle in result, this isn't strictly necessary
+ but just in case */
+ kset_cdr(last_non_cycle_pair, KNIL);
} else {
- /* There are pairs in the cycle, so close it */
- TValue first_cycle_pair = kcdr(last_non_cycle_pair);
- TValue last_cycle_pair = last_pair;
- kset_cdr(last_cycle_pair, first_cycle_pair);
+ /* There are pairs in the cycle, so close it */
+ TValue first_cycle_pair = kcdr(last_non_cycle_pair);
+ TValue last_cycle_pair = last_pair;
+ kset_cdr(last_cycle_pair, first_cycle_pair);
}
/* copy the list to avoid problems with continuations
@@ -610,34 +610,34 @@ void do_filter(klisp_State *K)
int32_t n = ivalue(xparams[3]);
if (!ttisboolean(obj)) {
- klispE_throw_simple(K, "expected boolean result");
- return;
+ klispE_throw_simple(K, "expected boolean result");
+ return;
}
if (kis_true(obj)) {
- TValue np = kcons(K, last_obj, KNIL);
- kset_cdr(last_pair, np);
- last_pair = np;
+ TValue np = kcons(K, last_obj, KNIL);
+ kset_cdr(last_pair, np);
+ last_pair = np;
}
if (n == 0) {
/* pass the rest of the list and last pair for cycle handling */
- kapply_cc(K, kcons(K, ls, last_pair));
+ kapply_cc(K, kcons(K, ls, last_pair));
} else {
- TValue new_n = i2tv(n-1);
- TValue first = kcar(ls);
- TValue new_env = kmake_empty_environment(K);
- krooted_tvs_push(K, new_env);
- /* have to unwrap the applicative to avoid extra evaluation of first */
- TValue new_expr = klist(K, 2, kunwrap(app), first, KNIL);
- krooted_tvs_push(K, new_expr);
- TValue new_cont =
- kmake_continuation(K, kget_cc(K), do_filter, 4, app,
- ls, last_pair, new_n);
- kset_cc(K, new_cont);
- krooted_tvs_pop(K);
- krooted_tvs_pop(K);
- ktail_eval(K, new_expr, new_env);
+ TValue new_n = i2tv(n-1);
+ TValue first = kcar(ls);
+ TValue new_env = kmake_empty_environment(K);
+ krooted_tvs_push(K, new_env);
+ /* have to unwrap the applicative to avoid extra evaluation of first */
+ TValue new_expr = klist(K, 2, kunwrap(app), first, KNIL);
+ krooted_tvs_push(K, new_expr);
+ TValue new_cont =
+ kmake_continuation(K, kget_cc(K), do_filter, 4, app,
+ ls, last_pair, new_n);
+ kset_cc(K, new_cont);
+ krooted_tvs_pop(K);
+ krooted_tvs_pop(K);
+ ktail_eval(K, new_expr, new_env);
}
}
@@ -662,15 +662,15 @@ void do_filter_cycle(klisp_State *K)
/* this continuation will close the cycle and return the list */
TValue encycle_cont =
- kmake_continuation(K, kget_cc(K), do_filter_encycle, 2,
- dummy, last_apair);
+ kmake_continuation(K, kget_cc(K), do_filter_encycle, 2,
+ dummy, last_apair);
krooted_tvs_push(K, encycle_cont);
/* schedule the filtering of the elements of the cycle */
/* add inert before first element to be discarded when KFALSE
is received */
TValue new_cont =
- kmake_continuation(K, encycle_cont, do_filter, 4, app,
- kcons(K, KINERT, ls), last_apair, cpairs);
+ kmake_continuation(K, encycle_cont, do_filter, 4, app,
+ kcons(K, KINERT, ls), last_apair, cpairs);
kset_cc(K, new_cont);
krooted_tvs_pop(K);
/* this will be like a nop and will continue with do_filter */
@@ -687,7 +687,7 @@ void filter(klisp_State *K)
UNUSED(xparams);
UNUSED(denv);
bind_2tp(K, ptree, "applicative", ttisapplicative, app,
- "any", anytype, ls);
+ "any", anytype, ls);
/* copy the list to ignore changes made by the applicative */
/* REFACTOR: do this in a single pass */
/* ASK John: the semantics when this is mixed with continuations,
@@ -705,17 +705,17 @@ void filter(klisp_State *K)
krooted_tvs_push(K, dummy);
TValue ret_cont = (cpairs == 0)?
- kmake_continuation(K, kget_cc(K), do_ret_cdr, 1, dummy)
- : kmake_continuation(K, kget_cc(K), do_filter_cycle, 3,
- app, dummy, i2tv(cpairs));
+ kmake_continuation(K, kget_cc(K), do_ret_cdr, 1, dummy)
+ : kmake_continuation(K, kget_cc(K), do_filter_cycle, 3,
+ app, dummy, i2tv(cpairs));
krooted_tvs_pop(K); /* already in cont */
krooted_tvs_push(K, ret_cont);
/* add inert before first element to be discarded when KFALSE
is received */
TValue new_cont =
- kmake_continuation(K, ret_cont, do_filter, 4, app,
- kcons(K, KINERT, ls), dummy, i2tv(pairs-cpairs));
+ kmake_continuation(K, ret_cont, do_filter, 4, app,
+ kcons(K, KINERT, ls), dummy, i2tv(pairs-cpairs));
kset_cc(K, new_cont);
krooted_tvs_pop(K);
/* this will be a nop, and will continue with do_filter */
@@ -742,26 +742,26 @@ void do_assoc(klisp_State *K)
int32_t pairs = ivalue(xparams[3]);
if (!ttisboolean(obj)) {
- klispE_throw_simple_with_irritants(K, "expected boolean", 1, obj);
- return;
+ klispE_throw_simple_with_irritants(K, "expected boolean", 1, obj);
+ return;
} else if (kis_true(obj) || pairs == 0) {
- TValue res = kis_true(obj)? kcar(ls) : KNIL;
- kapply_cc(K, res);
+ TValue res = kis_true(obj)? kcar(ls) : KNIL;
+ kapply_cc(K, res);
} else {
- /* object not YET found */
- TValue cont = kmake_continuation(K, kget_cc(K), do_assoc, 4, pred,
- cmp_obj, kcdr(ls), i2tv(pairs-1));
- /* not necessary but may save a continuation in some cases */
- kset_bool_check_cont(cont);
- kset_cc(K, cont);
- TValue exp = kcons(K, kcar(kcar(kcdr(ls))), KNIL);
- krooted_vars_push(K, &exp);
- exp = kcons(K, cmp_obj, exp);
- exp = kcons(K, pred, exp);
- /* TEMP for now use an empty environment for dynamic env */
- TValue env = kmake_empty_environment(K);
- krooted_vars_pop(K);
- ktail_eval(K, exp, env);
+ /* object not YET found */
+ TValue cont = kmake_continuation(K, kget_cc(K), do_assoc, 4, pred,
+ cmp_obj, kcdr(ls), i2tv(pairs-1));
+ /* not necessary but may save a continuation in some cases */
+ kset_bool_check_cont(cont);
+ kset_cc(K, cont);
+ TValue exp = kcons(K, kcar(kcar(kcdr(ls))), KNIL);
+ krooted_vars_push(K, &exp);
+ exp = kcons(K, cmp_obj, exp);
+ exp = kcons(K, pred, exp);
+ /* TEMP for now use an empty environment for dynamic env */
+ TValue env = kmake_empty_environment(K);
+ krooted_vars_pop(K);
+ ktail_eval(K, exp, env);
}
}
@@ -782,30 +782,30 @@ void assoc(klisp_State *K)
TValue res;
if (predp) {
- /* we'll need use continuations, copy list first to
- avoid troubles with mutation */
- ls = check_copy_list(K, ls, false, NULL, NULL);
- krooted_vars_push(K, &ls);
- ls = kcons(K, KINERT, ls); /* add dummy obj to stand as last
- compared obj */
- TValue cont = kmake_continuation(K, kget_cc(K), do_assoc, 4,
- maybe_pred, obj, ls, i2tv(pairs));
- krooted_vars_pop(K);
- kset_cc(K, cont);
- /* pass false to have it keep looking (in the whole list) */
- res = KFALSE;
+ /* we'll need use continuations, copy list first to
+ avoid troubles with mutation */
+ ls = check_copy_list(K, ls, false, NULL, NULL);
+ krooted_vars_push(K, &ls);
+ ls = kcons(K, KINERT, ls); /* add dummy obj to stand as last
+ compared obj */
+ TValue cont = kmake_continuation(K, kget_cc(K), do_assoc, 4,
+ maybe_pred, obj, ls, i2tv(pairs));
+ krooted_vars_pop(K);
+ kset_cc(K, cont);
+ /* pass false to have it keep looking (in the whole list) */
+ res = KFALSE;
} else {
- /* use equal?, no continuation needed */
- TValue tail = ls;
- res = KNIL;
- while(pairs--) {
- TValue first = kcar(tail);
- if (equal2p(K, kcar(first), obj)) {
- res = first;
- break;
- }
- tail = kcdr(tail);
- }
+ /* use equal?, no continuation needed */
+ TValue tail = ls;
+ res = KNIL;
+ while(pairs--) {
+ TValue first = kcar(tail);
+ if (equal2p(K, kcar(first), obj)) {
+ res = first;
+ break;
+ }
+ tail = kcdr(tail);
+ }
}
kapply_cc(K, res);
}
@@ -830,26 +830,26 @@ void do_memberp(klisp_State *K)
int32_t pairs = ivalue(xparams[3]);
if (!ttisboolean(obj)) {
- klispE_throw_simple_with_irritants(K, "expected boolean", 1, obj);
- return;
+ klispE_throw_simple_with_irritants(K, "expected boolean", 1, obj);
+ return;
} else if (kis_true(obj) || pairs == 0) {
- /* object found if obj is true and not found if obj is false */
- kapply_cc(K, obj);
+ /* object found if obj is true and not found if obj is false */
+ kapply_cc(K, obj);
} else {
- /* object not YET found */
- TValue cont = kmake_continuation(K, kget_cc(K), do_memberp, 4, pred,
- cmp_obj, kcdr(ls), i2tv(pairs-1));
- /* not necessary but may save a continuation in some cases */
- kset_bool_check_cont(cont);
- kset_cc(K, cont);
- TValue exp = kcons(K, kcar(ls), KNIL);
- krooted_vars_push(K, &exp);
- exp = kcons(K, cmp_obj, exp);
- exp = kcons(K, pred, exp);
- /* TEMP for now use an empty environment for dynamic env */
- TValue env = kmake_empty_environment(K);
- krooted_vars_pop(K);
- ktail_eval(K, exp, env);
+ /* object not YET found */
+ TValue cont = kmake_continuation(K, kget_cc(K), do_memberp, 4, pred,
+ cmp_obj, kcdr(ls), i2tv(pairs-1));
+ /* not necessary but may save a continuation in some cases */
+ kset_bool_check_cont(cont);
+ kset_cc(K, cont);
+ TValue exp = kcons(K, kcar(ls), KNIL);
+ krooted_vars_push(K, &exp);
+ exp = kcons(K, cmp_obj, exp);
+ exp = kcons(K, pred, exp);
+ /* TEMP for now use an empty environment for dynamic env */
+ TValue env = kmake_empty_environment(K);
+ krooted_vars_pop(K);
+ ktail_eval(K, exp, env);
}
}
@@ -868,34 +868,34 @@ void memberp(klisp_State *K)
/* first pass, check structure */
int32_t pairs;
if (predp) { /* copy if a custom predicate is used */
- ls = check_copy_list(K, ls, false, &pairs, NULL);
+ ls = check_copy_list(K, ls, false, &pairs, NULL);
} else {
- check_list(K, true, ls, &pairs, NULL);
+ check_list(K, true, ls, &pairs, NULL);
}
TValue res;
if (predp) {
- /* we'll need use continuations */
- krooted_tvs_push(K, ls);
- TValue cont = kmake_continuation(K, kget_cc(K), do_memberp, 4,
- maybe_pred, obj, ls, i2tv(pairs));
- krooted_tvs_pop(K);
- kset_cc(K, cont);
- /* pass false to have it keep looking (in the whole list) */
- res = KFALSE;
+ /* we'll need use continuations */
+ krooted_tvs_push(K, ls);
+ TValue cont = kmake_continuation(K, kget_cc(K), do_memberp, 4,
+ maybe_pred, obj, ls, i2tv(pairs));
+ krooted_tvs_pop(K);
+ kset_cc(K, cont);
+ /* pass false to have it keep looking (in the whole list) */
+ res = KFALSE;
} else {
- /* if using equal? we need no continuation, we can
- do it all here */
- TValue tail = ls;
- res = KFALSE;
- while(pairs--) {
- TValue first = kcar(tail);
- if (equal2p(K, first, obj)) {
- res = KTRUE;
- break;
- }
- tail = kcdr(tail);
- }
+ /* if using equal? we need no continuation, we can
+ do it all here */
+ TValue tail = ls;
+ res = KFALSE;
+ while(pairs--) {
+ TValue first = kcar(tail);
+ if (equal2p(K, first, obj)) {
+ res = KTRUE;
+ break;
+ }
+ tail = kcdr(tail);
+ }
}
kapply_cc(K, res);
}
@@ -916,19 +916,19 @@ void finite_listp(klisp_State *K)
TValue res = KTRUE;
TValue tail = ptree;
while(pairs--) {
- TValue first = kcar(tail);
- tail = kcdr(tail);
- TValue itail = first;
- while(ttispair(itail) && !kis_marked(itail)) {
- kmark(itail);
- itail = kcdr(itail);
- }
- unmark_list(K, first);
+ TValue first = kcar(tail);
+ tail = kcdr(tail);
+ TValue itail = first;
+ while(ttispair(itail) && !kis_marked(itail)) {
+ kmark(itail);
+ itail = kcdr(itail);
+ }
+ unmark_list(K, first);
- if (!ttisnil(itail)) {
- res = KFALSE;
- break;
- }
+ if (!ttisnil(itail)) {
+ res = KFALSE;
+ break;
+ }
}
kapply_cc(K, res);
}
@@ -949,19 +949,19 @@ void countable_listp(klisp_State *K)
TValue res = KTRUE;
TValue tail = ptree;
while(pairs--) {
- TValue first = kcar(tail);
- tail = kcdr(tail);
- TValue itail = first;
- while(ttispair(itail) && !kis_marked(itail)) {
- kmark(itail);
- itail = kcdr(itail);
- }
- unmark_list(K, first);
+ TValue first = kcar(tail);
+ tail = kcdr(tail);
+ TValue itail = first;
+ while(ttispair(itail) && !kis_marked(itail)) {
+ kmark(itail);
+ itail = kcdr(itail);
+ }
+ unmark_list(K, first);
- if (!ttisnil(itail) && !ttispair(itail)) {
- res = KFALSE;
- break;
- }
+ if (!ttisnil(itail) && !ttispair(itail)) {
+ res = KFALSE;
+ break;
+ }
}
kapply_cc(K, res);
}
@@ -992,17 +992,17 @@ void do_reduce_prec(klisp_State *K)
kset_car(last_pair, obj);
if (cpairs == 0) {
- /* pass the first element to the do_reduce_inc continuation */
- kapply_cc(K, kcar(first_pair));
+ /* pass the first element to the do_reduce_inc continuation */
+ kapply_cc(K, kcar(first_pair));
} else {
- TValue expr = klist(K, 2, kunwrap(prec), kcar(ls));
- krooted_tvs_push(K, expr);
- TValue new_cont =
- kmake_continuation(K, kget_cc(K), do_reduce_prec,
- 5, first_pair, ls, i2tv(cpairs-1), prec, denv);
- kset_cc(K, new_cont);
- krooted_tvs_pop(K);
- ktail_eval(K, expr, denv);
+ TValue expr = klist(K, 2, kunwrap(prec), kcar(ls));
+ krooted_tvs_push(K, expr);
+ TValue new_cont =
+ kmake_continuation(K, kget_cc(K), do_reduce_prec,
+ 5, first_pair, ls, i2tv(cpairs-1), prec, denv);
+ kset_cc(K, new_cont);
+ krooted_tvs_pop(K);
+ ktail_eval(K, expr, denv);
}
}
@@ -1043,7 +1043,7 @@ void do_reduce_combine(klisp_State *K)
/* obj: cyclic_res */
TValue cyclic_res = obj;
TValue expr = klist(K, 3, kunwrap(bin), acyclic_res,
- cyclic_res);
+ cyclic_res);
ktail_eval(K, expr, denv);
}
@@ -1077,23 +1077,23 @@ void do_reduce_cycle(klisp_State *K)
*/
if (has_acyclic_partp) {
- TValue acyclic_obj = obj;
- TValue combine_cont =
- kmake_continuation(K, kget_cc(K), do_reduce_combine,
- 3, acyclic_obj, bin, denv);
- kset_cc(K, combine_cont); /* implitly rooted */
+ TValue acyclic_obj = obj;
+ TValue combine_cont =
+ kmake_continuation(K, kget_cc(K), do_reduce_combine,
+ 3, acyclic_obj, bin, denv);
+ kset_cc(K, combine_cont); /* implitly rooted */
} /* if there is no acyclic part, just let the result pass through */
TValue post_cont =
- kmake_continuation(K, kget_cc(K), do_reduce_postc,
- 2, postc, denv);
+ kmake_continuation(K, kget_cc(K), do_reduce_postc,
+ 2, postc, denv);
kset_cc(K, post_cont); /* implitly rooted */
/* pass one less so that pre_cont can pass the first argument
to the continuation */
TValue in_cont =
- kmake_continuation(K, kget_cc(K), do_reduce,
- 4, kcdr(ls), i2tv(cpairs - 1), inc, denv);
+ kmake_continuation(K, kget_cc(K), do_reduce,
+ 4, kcdr(ls), i2tv(cpairs - 1), inc, denv);
kset_cc(K, in_cont);
/* add dummy to allow passing inert to pre_cont */
@@ -1102,8 +1102,8 @@ void do_reduce_cycle(klisp_State *K)
/* pass ls as the first pair to be passed to the do_reduce
continuation */
TValue pre_cont =
- kmake_continuation(K, kget_cc(K), do_reduce_prec,
- 5, ls, dummy, i2tv(cpairs), prec, denv);
+ kmake_continuation(K, kget_cc(K), do_reduce_prec,
+ 5, ls, dummy, i2tv(cpairs), prec, denv);
kset_cc(K, pre_cont);
krooted_tvs_pop(K);
/* this will overwrite dummy, but that's ok */
@@ -1129,22 +1129,22 @@ void do_reduce(klisp_State *K)
TValue denv = xparams[3];
if (pairs == 0) {
- /* NOTE: this continuation could have been avoided (made a
- tail context) but since it isn't a requirement having
- this will help with error signaling and backtraces */
- kapply_cc(K, obj);
+ /* NOTE: this continuation could have been avoided (made a
+ tail context) but since it isn't a requirement having
+ this will help with error signaling and backtraces */
+ kapply_cc(K, obj);
} else {
- TValue next = kcar(ls);
- TValue expr = klist(K, 3, kunwrap(bin), obj, next);
- krooted_tvs_push(K, expr);
+ TValue next = kcar(ls);
+ TValue expr = klist(K, 3, kunwrap(bin), obj, next);
+ krooted_tvs_push(K, expr);
- TValue new_cont =
- kmake_continuation(K, kget_cc(K), do_reduce, 4,
- kcdr(ls), i2tv(pairs-1), bin, denv);
- kset_cc(K, new_cont);
- krooted_tvs_pop(K);
- /* use the dynamic environment of the call to reduce */
- ktail_eval(K, expr, denv);
+ TValue new_cont =
+ kmake_continuation(K, kget_cc(K), do_reduce, 4,
+ kcdr(ls), i2tv(pairs-1), bin, denv);
+ kset_cc(K, new_cont);
+ krooted_tvs_pop(K);
+ /* use the dynamic environment of the call to reduce */
+ ktail_eval(K, expr, denv);
}
}
@@ -1164,29 +1164,29 @@ void reduce(klisp_State *K)
UNUSED(xparams);
bind_al3tp(K, ptree, "any", anytype, ls, "applicative",
- ttisapplicative, bin, "any", anytype, id, rest);
+ ttisapplicative, bin, "any", anytype, id, rest);
TValue prec, inc, postc;
bool extended_form = !ttisnil(rest);
if (extended_form) {
- /* the variables are an artifact of the way bind_3tp macro works,
- XXX: this will also send wrong error msgs (bad number of arg) */
- bind_3tp(K, rest,
- "applicative", ttisapplicative, prec_h,
- "applicative", ttisapplicative, inc_h,
- "applicative", ttisapplicative, postc_h);
- prec = prec_h;
- inc = inc_h;
- postc = postc_h;
+ /* the variables are an artifact of the way bind_3tp macro works,
+ XXX: this will also send wrong error msgs (bad number of arg) */
+ bind_3tp(K, rest,
+ "applicative", ttisapplicative, prec_h,
+ "applicative", ttisapplicative, inc_h,
+ "applicative", ttisapplicative, postc_h);
+ prec = prec_h;
+ inc = inc_h;
+ postc = postc_h;
} else {
- /* dummy init */
- prec = inc = postc = KINERT;
+ /* dummy init */
+ prec = inc = postc = KINERT;
}
/* the easy case first */
if (ttisnil(ls)) {
- kapply_cc(K, id);
+ kapply_cc(K, id);
}
/* TODO all of these in one procedure */
@@ -1200,37 +1200,37 @@ void reduce(klisp_State *K)
/* REFACTOR: add an extra return value to check_copy_list to output
the last pair of the list */
while(dapairs--)
- first_cycle_pair = kcdr(first_cycle_pair);
+ first_cycle_pair = kcdr(first_cycle_pair);
TValue res;
if (cpairs != 0) {
- if (!extended_form) {
- klispE_throw_simple(K, "no cyclic handling applicatives");
- return;
- }
- /* make cycle reducing cont */
- TValue cyc_cont =
- kmake_continuation(K, kget_cc(K), do_reduce_cycle, 8,
- first_cycle_pair, i2tv(cpairs), bin, prec,
- inc, postc, denv, b2tv(apairs != 0));
- kset_cc(K, cyc_cont);
+ if (!extended_form) {
+ klispE_throw_simple(K, "no cyclic handling applicatives");
+ return;
+ }
+ /* make cycle reducing cont */
+ TValue cyc_cont =
+ kmake_continuation(K, kget_cc(K), do_reduce_cycle, 8,
+ first_cycle_pair, i2tv(cpairs), bin, prec,
+ inc, postc, denv, b2tv(apairs != 0));
+ kset_cc(K, cyc_cont);
}
if (apairs == 0) {
- /* this will be ignore by cyc_cont */
- res = KINERT;
+ /* this will be ignore by cyc_cont */
+ res = KINERT;
} else {
- /* this will pass the parent continuation either
- a list of (rem-ls result) if there is a cycle or
- result if there is no cycle, this should be a list
- and not a regular pair to allow the above case of
- a one element list to signal no acyclic part */
- TValue acyc_cont =
- kmake_continuation(K, kget_cc(K), do_reduce, 4,
- kcdr(ls), i2tv(apairs-1), bin, denv);
- kset_cc(K, acyc_cont);
- res = kcar(ls);
+ /* this will pass the parent continuation either
+ a list of (rem-ls result) if there is a cycle or
+ result if there is no cycle, this should be a list
+ and not a regular pair to allow the above case of
+ a one element list to signal no acyclic part */
+ TValue acyc_cont =
+ kmake_continuation(K, kget_cc(K), do_reduce, 4,
+ kcdr(ls), i2tv(apairs-1), bin, denv);
+ kset_cc(K, acyc_cont);
+ res = kcar(ls);
}
kapply_cc(K, res);
}
@@ -1243,10 +1243,10 @@ void kinit_pairs_lists_ground_env(klisp_State *K)
/* 4.6.1 pair? */
add_applicative(K, ground_env, "pair?", typep, 2, symbol,
- i2tv(K_TPAIR));
+ i2tv(K_TPAIR));
/* 4.6.2 null? */
add_applicative(K, ground_env, "null?", typep, 2, symbol,
- i2tv(K_TNIL));
+ i2tv(K_TNIL));
/* 4.6.3 cons */
add_applicative(K, ground_env, "cons", cons, 0);
/* 5.2.1 list */
@@ -1255,66 +1255,66 @@ void kinit_pairs_lists_ground_env(klisp_State *K)
add_applicative(K, ground_env, "list*", listS, 0);
/* 5.4.1 car, cdr */
add_applicative(K, ground_env, "car", c_ad_r, 2, symbol,
- C_AD_R_PARAM(1, 0x0000));
+ C_AD_R_PARAM(1, 0x0000));
add_applicative(K, ground_env, "cdr", c_ad_r, 2, symbol,
- C_AD_R_PARAM(1, 0x0001));
+ C_AD_R_PARAM(1, 0x0001));
/* 5.4.2 caar, cadr, ... cddddr */
add_applicative(K, ground_env, "caar", c_ad_r, 2, symbol,
- C_AD_R_PARAM(2, 0x0000));
+ C_AD_R_PARAM(2, 0x0000));
add_applicative(K, ground_env, "cadr", c_ad_r, 2, symbol,
- C_AD_R_PARAM(2, 0x0001));
+ C_AD_R_PARAM(2, 0x0001));
add_applicative(K, ground_env, "cdar", c_ad_r, 2, symbol,
- C_AD_R_PARAM(2, 0x0010));
+ C_AD_R_PARAM(2, 0x0010));
add_applicative(K, ground_env, "cddr", c_ad_r, 2, symbol,
- C_AD_R_PARAM(2, 0x0011));
+ C_AD_R_PARAM(2, 0x0011));
add_applicative(K, ground_env, "caaar", c_ad_r, 2, symbol,
- C_AD_R_PARAM(3, 0x0000));
+ C_AD_R_PARAM(3, 0x0000));
add_applicative(K, ground_env, "caadr", c_ad_r, 2, symbol,
- C_AD_R_PARAM(3, 0x0001));
+ C_AD_R_PARAM(3, 0x0001));
add_applicative(K, ground_env, "cadar", c_ad_r, 2, symbol,
- C_AD_R_PARAM(3, 0x0010));
+ C_AD_R_PARAM(3, 0x0010));
add_applicative(K, ground_env, "caddr", c_ad_r, 2, symbol,
- C_AD_R_PARAM(3, 0x0011));
+ C_AD_R_PARAM(3, 0x0011));
add_applicative(K, ground_env, "cdaar", c_ad_r, 2, symbol,
- C_AD_R_PARAM(3, 0x0100));
+ C_AD_R_PARAM(3, 0x0100));
add_applicative(K, ground_env, "cdadr", c_ad_r, 2, symbol,
- C_AD_R_PARAM(3, 0x0101));
+ C_AD_R_PARAM(3, 0x0101));
add_applicative(K, ground_env, "cddar", c_ad_r, 2, symbol,
- C_AD_R_PARAM(3, 0x0110));
+ C_AD_R_PARAM(3, 0x0110));
add_applicative(K, ground_env, "cdddr", c_ad_r, 2, symbol,
- C_AD_R_PARAM(3, 0x0111));
+ C_AD_R_PARAM(3, 0x0111));
add_applicative(K, ground_env, "caaaar", c_ad_r, 2, symbol,
- C_AD_R_PARAM(4, 0x0000));
+ C_AD_R_PARAM(4, 0x0000));
add_applicative(K, ground_env, "caaadr", c_ad_r, 2, symbol,
- C_AD_R_PARAM(4, 0x0001));
+ C_AD_R_PARAM(4, 0x0001));
add_applicative(K, ground_env, "caadar", c_ad_r, 2, symbol,
- C_AD_R_PARAM(4, 0x0010));
+ C_AD_R_PARAM(4, 0x0010));
add_applicative(K, ground_env, "caaddr", c_ad_r, 2, symbol,
- C_AD_R_PARAM(4, 0x0011));
+ C_AD_R_PARAM(4, 0x0011));
add_applicative(K, ground_env, "cadaar", c_ad_r, 2, symbol,
- C_AD_R_PARAM(4, 0x0100));
+ C_AD_R_PARAM(4, 0x0100));
add_applicative(K, ground_env, "cadadr", c_ad_r, 2, symbol,
- C_AD_R_PARAM(4, 0x0101));
+ C_AD_R_PARAM(4, 0x0101));
add_applicative(K, ground_env, "caddar", c_ad_r, 2, symbol,
- C_AD_R_PARAM(4, 0x0110));
+ C_AD_R_PARAM(4, 0x0110));
add_applicative(K, ground_env, "cadddr", c_ad_r, 2, symbol,
- C_AD_R_PARAM(4, 0x0111));
+ C_AD_R_PARAM(4, 0x0111));
add_applicative(K, ground_env, "cdaaar", c_ad_r, 2, symbol,
- C_AD_R_PARAM(4, 0x1000));
+ C_AD_R_PARAM(4, 0x1000));
add_applicative(K, ground_env, "cdaadr", c_ad_r, 2, symbol,
- C_AD_R_PARAM(4, 0x1001));
+ C_AD_R_PARAM(4, 0x1001));
add_applicative(K, ground_env, "cdadar", c_ad_r, 2, symbol,
- C_AD_R_PARAM(4, 0x1010));
+ C_AD_R_PARAM(4, 0x1010));
add_applicative(K, ground_env, "cdaddr", c_ad_r, 2, symbol,
- C_AD_R_PARAM(4, 0x1011));
+ C_AD_R_PARAM(4, 0x1011));
add_applicative(K, ground_env, "cddaar", c_ad_r, 2, symbol,
- C_AD_R_PARAM(4, 0x1100));
+ C_AD_R_PARAM(4, 0x1100));
add_applicative(K, ground_env, "cddadr", c_ad_r, 2, symbol,
- C_AD_R_PARAM(4, 0x1101));
+ C_AD_R_PARAM(4, 0x1101));
add_applicative(K, ground_env, "cdddar", c_ad_r, 2, symbol,
- C_AD_R_PARAM(4, 0x1110));
+ C_AD_R_PARAM(4, 0x1110));
add_applicative(K, ground_env, "cddddr", c_ad_r, 2, symbol,
- C_AD_R_PARAM(4, 0x1111));
+ C_AD_R_PARAM(4, 0x1111));
/* 5.?.? make-list */
add_applicative(K, ground_env, "make-list", make_list, 0);
/* 5.?.? list-copy */
diff --git a/src/kgports.c b/src/kgports.c
@@ -82,13 +82,13 @@ void with_file(klisp_State *K)
TValue key = xparams[2];
bind_2tp(K, ptree, "string", ttisstring, filename,
- "combiner", ttiscombiner, comb);
+ "combiner", ttiscombiner, comb);
TValue new_port = kmake_fport(K, filename, writep, false);
krooted_tvs_push(K, new_port);
/* make the continuation to close the file before returning */
TValue new_cont = kmake_continuation(K, kget_cc(K),
- do_close_file_ret, 1, new_port);
+ do_close_file_ret, 1, new_port);
kset_cc(K, new_cont); /* cont implicitly rooted */
krooted_tvs_pop(K); /* new_port is in cont */
@@ -169,14 +169,14 @@ void open_mport(klisp_State *K)
/* This is kinda ugly but... */
if (writep) {
- check_0p(K, ptree);
- buffer = KINERT;
+ check_0p(K, ptree);
+ buffer = KINERT;
} else if (binaryp) {
- bind_1tp(K, ptree, "bytevector", ttisbytevector, bb);
- buffer = bb;
+ bind_1tp(K, ptree, "bytevector", ttisbytevector, bb);
+ buffer = bb;
} else {
- bind_1tp(K, ptree, "string", ttisstring, str);
- buffer = str;
+ bind_1tp(K, ptree, "string", ttisstring, str);
+ buffer = str;
}
TValue new_port = kmake_mport(K, buffer, writep, binaryp);
@@ -203,11 +203,11 @@ void close_file(klisp_State *K)
bool dir_ok = writep? kport_is_output(port) : kport_is_input(port);
if (dir_ok) {
- kclose_port(K, port);
- kapply_cc(K, KINERT);
+ kclose_port(K, port);
+ kapply_cc(K, KINERT);
} else {
- klispE_throw_simple(K, "wrong input/output direction");
- return;
+ klispE_throw_simple(K, "wrong input/output direction");
+ return;
}
}
@@ -229,14 +229,14 @@ void close_port(klisp_State *K)
bind_1tp(K, ptree, "port", ttisport, port);
bool dir_ok = !((writep && !kport_is_output(port)) ||
- (readp && !kport_is_input(port)));
+ (readp && !kport_is_input(port)));
if (dir_ok) {
- kclose_port(K, port);
- kapply_cc(K, KINERT);
+ kclose_port(K, port);
+ kapply_cc(K, KINERT);
} else {
- klispE_throw_simple(K, "wrong input/output direction");
- return;
+ klispE_throw_simple(K, "wrong input/output direction");
+ return;
}
}
@@ -255,21 +255,21 @@ void get_output_buffer(klisp_State *K)
bind_1tp(K, ptree, "port", ttismport, port);
if (binaryp && !kport_is_binary(port)) {
- klispE_throw_simple(K, "the port should be a bytevector port");
- return;
+ klispE_throw_simple(K, "the port should be a bytevector port");
+ return;
} else if (!binaryp && !kport_is_textual(port)) {
- klispE_throw_simple(K, "the port should be a string port");
- return;
+ klispE_throw_simple(K, "the port should be a string port");
+ return;
} else if (!kport_is_output(port)) {
- klispE_throw_simple(K, "the port should be an output port");
- return;
+ klispE_throw_simple(K, "the port should be an output port");
+ return;
}
TValue ret = binaryp?
- kbytevector_new_bs(K,
- kbytevector_buf(kmport_buf(port)),
- kmport_off(port)) :
- kstring_new_bs(K, kstring_buf(kmport_buf(port)), kmport_off(port));
+ kbytevector_new_bs(K,
+ kbytevector_buf(kmport_buf(port)),
+ kmport_off(port)) :
+ kstring_new_bs(K, kstring_buf(kmport_buf(port)), kmport_off(port));
kapply_cc(K, ret);
}
@@ -285,18 +285,18 @@ void gread(klisp_State *K)
TValue port = ptree;
if (!get_opt_tpar(K, port, "port", ttisport)) {
- port = kcdr(K->kd_in_port_key); /* access directly */
+ port = kcdr(K->kd_in_port_key); /* access directly */
}
if (!kport_is_input(port)) {
- klispE_throw_simple(K, "the port should be an input port");
- return;
+ klispE_throw_simple(K, "the port should be an input port");
+ return;
} else if (!kport_is_textual(port)) {
- klispE_throw_simple(K, "the port should be a textual port");
- return;
+ klispE_throw_simple(K, "the port should be a textual port");
+ return;
} else if (kport_is_closed(port)) {
- klispE_throw_simple(K, "the port is already closed");
- return;
+ klispE_throw_simple(K, "the port is already closed");
+ return;
}
/* this may throw an error, that's ok */
@@ -315,21 +315,21 @@ void gwrite(klisp_State *K)
UNUSED(denv);
bind_al1tp(K, ptree, "any", anytype, obj,
- port);
+ port);
if (!get_opt_tpar(K, port, "port", ttisport)) {
- port = kcdr(K->kd_out_port_key); /* access directly */
+ port = kcdr(K->kd_out_port_key); /* access directly */
}
if (!kport_is_output(port)) {
- klispE_throw_simple(K, "the port should be an output port");
- return;
+ klispE_throw_simple(K, "the port should be an output port");
+ return;
} else if (!kport_is_textual(port)) {
- klispE_throw_simple(K, "the port should be a textual port");
- return;
+ klispE_throw_simple(K, "the port should be a textual port");
+ return;
} else if (kport_is_closed(port)) {
- klispE_throw_simple(K, "the port is already closed");
- return;
+ klispE_throw_simple(K, "the port is already closed");
+ return;
}
/* false: quote strings, escape chars */
@@ -348,21 +348,21 @@ void gwrite_simple(klisp_State *K)
UNUSED(denv);
bind_al1tp(K, ptree, "any", anytype, obj,
- port);
+ port);
if (!get_opt_tpar(K, port, "port", ttisport)) {
- port = kcdr(K->kd_out_port_key); /* access directly */
+ port = kcdr(K->kd_out_port_key); /* access directly */
}
if (!kport_is_output(port)) {
- klispE_throw_simple(K, "the port should be an output port");
- return;
+ klispE_throw_simple(K, "the port should be an output port");
+ return;
} else if (!kport_is_textual(port)) {
- klispE_throw_simple(K, "the port should be a textual port");
- return;
+ klispE_throw_simple(K, "the port should be a textual port");
+ return;
} else if (kport_is_closed(port)) {
- klispE_throw_simple(K, "the port is already closed");
- return;
+ klispE_throw_simple(K, "the port is already closed");
+ return;
}
kwrite_simple_to_port(K, port, obj);
@@ -384,18 +384,18 @@ void newline(klisp_State *K)
TValue port = ptree;
if (!get_opt_tpar(K, port, "port", ttisport)) {
- port = kcdr(K->kd_out_port_key); /* access directly */
+ port = kcdr(K->kd_out_port_key); /* access directly */
}
if (!kport_is_output(port)) {
- klispE_throw_simple(K, "the port should be an output port");
- return;
+ klispE_throw_simple(K, "the port should be an output port");
+ return;
} else if (!kport_is_textual(port)) {
- klispE_throw_simple(K, "the port should be a textual port");
- return;
+ klispE_throw_simple(K, "the port should be a textual port");
+ return;
} else if (kport_is_closed(port)) {
- klispE_throw_simple(K, "the port is already closed");
- return;
+ klispE_throw_simple(K, "the port is already closed");
+ return;
}
kwrite_newline_to_port(K, port);
@@ -413,21 +413,21 @@ void write_char(klisp_State *K)
UNUSED(denv);
bind_al1tp(K, ptree, "char", ttischar, ch,
- port);
+ port);
if (!get_opt_tpar(K, port, "port", ttisport)) {
- port = kcdr(K->kd_out_port_key); /* access directly */
+ port = kcdr(K->kd_out_port_key); /* access directly */
}
if (!kport_is_output(port)) {
- klispE_throw_simple(K, "the port should be an output port");
- return;
+ klispE_throw_simple(K, "the port should be an output port");
+ return;
} else if (!kport_is_textual(port)) {
- klispE_throw_simple(K, "the port should be a textual port");
- return;
+ klispE_throw_simple(K, "the port should be a textual port");
+ return;
} else if (kport_is_closed(port)) {
- klispE_throw_simple(K, "the port is already closed");
- return;
+ klispE_throw_simple(K, "the port is already closed");
+ return;
}
kwrite_char_to_port(K, port, ch);
@@ -450,18 +450,18 @@ void read_peek_char(klisp_State *K)
TValue port = ptree;
if (!get_opt_tpar(K, port, "port", ttisport)) {
- port = kcdr(K->kd_in_port_key); /* access directly */
+ port = kcdr(K->kd_in_port_key); /* access directly */
}
if (!kport_is_input(port)) {
- klispE_throw_simple(K, "the port should be an input port");
- return;
+ klispE_throw_simple(K, "the port should be an input port");
+ return;
} else if (!kport_is_textual(port)) {
- klispE_throw_simple(K, "the port should be a textual port");
- return;
+ klispE_throw_simple(K, "the port should be a textual port");
+ return;
} else if (kport_is_closed(port)) {
- klispE_throw_simple(K, "the port is already closed");
- return;
+ klispE_throw_simple(K, "the port is already closed");
+ return;
}
TValue obj = kread_peek_char_from_port(K, port, ret_charp);
@@ -491,18 +491,18 @@ void char_readyp(klisp_State *K)
TValue port = ptree;
if (!get_opt_tpar(K, port, "port", ttisport)) {
- port = kcdr(K->kd_in_port_key); /* access directly */
+ port = kcdr(K->kd_in_port_key); /* access directly */
}
if (!kport_is_input(port)) {
- klispE_throw_simple(K, "the port should be an input port");
- return;
+ klispE_throw_simple(K, "the port should be an input port");
+ return;
} else if (!kport_is_textual(port)) {
- klispE_throw_simple(K, "the port should be a textual port");
- return;
+ klispE_throw_simple(K, "the port should be a textual port");
+ return;
} else if (kport_is_closed(port)) {
- klispE_throw_simple(K, "the port is already closed");
- return;
+ klispE_throw_simple(K, "the port is already closed");
+ return;
}
/* TODO: check if there are pending chars */
@@ -522,18 +522,18 @@ void write_u8(klisp_State *K)
bind_al1tp(K, ptree, "u8", ttisu8, u8, port);
if (!get_opt_tpar(K, port, "port", ttisport)) {
- port = kcdr(K->kd_out_port_key); /* access directly */
+ port = kcdr(K->kd_out_port_key); /* access directly */
}
if (!kport_is_output(port)) {
- klispE_throw_simple(K, "the port should be an output port");
- return;
+ klispE_throw_simple(K, "the port should be an output port");
+ return;
} else if (!kport_is_binary(port)) {
- klispE_throw_simple(K, "the port should be a binary port");
- return;
+ klispE_throw_simple(K, "the port should be a binary port");
+ return;
} else if (kport_is_closed(port)) {
- klispE_throw_simple(K, "the port is already closed");
- return;
+ klispE_throw_simple(K, "the port is already closed");
+ return;
}
kwrite_u8_to_port(K, port, u8);
@@ -556,18 +556,18 @@ void read_peek_u8(klisp_State *K)
TValue port = ptree;
if (!get_opt_tpar(K, port, "port", ttisport)) {
- port = kcdr(K->kd_in_port_key); /* access directly */
+ port = kcdr(K->kd_in_port_key); /* access directly */
}
if (!kport_is_input(port)) {
- klispE_throw_simple(K, "the port should be an input port");
- return;
+ klispE_throw_simple(K, "the port should be an input port");
+ return;
} else if (!kport_is_binary(port)) {
- klispE_throw_simple(K, "the port should be a binary port");
- return;
+ klispE_throw_simple(K, "the port should be a binary port");
+ return;
} else if (kport_is_closed(port)) {
- klispE_throw_simple(K, "the port is already closed");
- return;
+ klispE_throw_simple(K, "the port is already closed");
+ return;
}
TValue obj = kread_peek_u8_from_port(K, port, ret_u8p);
@@ -597,18 +597,18 @@ void u8_readyp(klisp_State *K)
TValue port = ptree;
if (!get_opt_tpar(K, port, "port", ttisport)) {
- port = kcdr(K->kd_in_port_key); /* access directly */
+ port = kcdr(K->kd_in_port_key); /* access directly */
}
if (!kport_is_input(port)) {
- klispE_throw_simple(K, "the port should be an input port");
- return;
+ klispE_throw_simple(K, "the port should be an input port");
+ return;
} else if (!kport_is_binary(port)) {
- klispE_throw_simple(K, "the port should be a binary port");
- return;
+ klispE_throw_simple(K, "the port should be a binary port");
+ return;
} else if (kport_is_closed(port)) {
- klispE_throw_simple(K, "the port is already closed");
- return;
+ klispE_throw_simple(K, "the port is already closed");
+ return;
}
/* TODO: check if there are pending chars */
@@ -630,13 +630,13 @@ void call_with_file(klisp_State *K)
UNUSED(denv);
bind_2tp(K, ptree, "string", ttisstring, filename,
- "combiner", ttiscombiner, comb);
+ "combiner", ttiscombiner, comb);
TValue new_port = kmake_fport(K, filename, writep, false);
krooted_tvs_push(K, new_port);
/* make the continuation to close the file before returning */
TValue new_cont = kmake_continuation(K, kget_cc(K),
- do_close_file_ret, 1, new_port);
+ do_close_file_ret, 1, new_port);
kset_cc(K, new_cont); /* implicit rooting */
krooted_tvs_pop(K); /* new_port is in new_cont */
TValue empty_env = kmake_empty_environment(K);
@@ -679,7 +679,7 @@ TValue make_guarded_read_cont(klisp_State *K, TValue parent, TValue port)
{
/* create the guard to close file after read errors */
TValue exit_int = kmake_operative(K, do_int_close_file,
- 1, port);
+ 1, port);
krooted_tvs_push(K, exit_int);
TValue exit_guard = kcons(K, K->error_cont, exit_int);
krooted_tvs_pop(K); /* alread in guard */
@@ -694,11 +694,11 @@ TValue make_guarded_read_cont(klisp_State *K, TValue parent, TValue port)
TValue env = kmake_empty_environment(K);
krooted_tvs_push(K, env);
TValue outer_cont = kmake_continuation(K, parent,
- do_pass_value, 2, entry_guards, env);
+ do_pass_value, 2, entry_guards, env);
kset_outer_cont(outer_cont);
krooted_tvs_push(K, outer_cont);
TValue inner_cont = kmake_continuation(K, outer_cont,
- do_pass_value, 2, exit_guards, env);
+ do_pass_value, 2, exit_guards, env);
kset_inner_cont(inner_cont);
krooted_tvs_pop(K); krooted_tvs_pop(K); krooted_tvs_pop(K);
return inner_cont;
@@ -725,20 +725,20 @@ void load(klisp_State *K)
bind_1tp(K, ptree, "string", ttisstring, filename);
/* the reads must be guarded to close the file if there is some error
- this continuation also will return inert after the evaluation of the
- last expression is done */
+ this continuation also will return inert after the evaluation of the
+ last expression is done */
TValue port = kmake_fport(K, filename, false, false);
krooted_tvs_push(K, port);
TValue inert_cont = kmake_continuation(K, kget_cc(K), do_return_value, 1,
- KINERT);
+ KINERT);
krooted_tvs_push(K, inert_cont);
TValue guarded_cont = make_guarded_read_cont(K, kget_cc(K), port);
/* this will be used later, but contruct it now to use the
current continuation as parent
- GC: root this obj */
+ GC: root this obj */
kset_cc(K, guarded_cont); /* implicit rooting */
/* any error will close the port */
TValue ls = kread_list_from_port(K, port, false); /* immutable pairs */
@@ -750,24 +750,24 @@ void load(klisp_State *K)
if (ttisnil(ls)) {
- krooted_tvs_pop(K); /* port */
- kapply_cc(K, KINERT);
+ krooted_tvs_pop(K); /* port */
+ kapply_cc(K, KINERT);
} else {
- TValue tail = kcdr(ls);
- if (ttispair(tail)) {
- krooted_tvs_push(K, ls);
- TValue new_cont = kmake_continuation(K, kget_cc(K),
- do_seq, 2, tail, denv);
- kset_cc(K, new_cont);
+ TValue tail = kcdr(ls);
+ if (ttispair(tail)) {
+ krooted_tvs_push(K, ls);
+ TValue new_cont = kmake_continuation(K, kget_cc(K),
+ do_seq, 2, tail, denv);
+ kset_cc(K, new_cont);
#if KTRACK_SI
- /* put the source info of the list including the element
- that we are about to evaluate */
- kset_source_info(K, new_cont, ktry_get_si(K, ls));
+ /* put the source info of the list including the element
+ that we are about to evaluate */
+ kset_source_info(K, new_cont, ktry_get_si(K, ls));
#endif
- krooted_tvs_pop(K); /* ls */
- }
- krooted_tvs_pop(K); /* port */
- ktail_eval(K, kcar(ls), denv);
+ krooted_tvs_pop(K); /* ls */
+ }
+ krooted_tvs_pop(K); /* port */
+ ktail_eval(K, kcar(ls), denv);
}
}
@@ -781,7 +781,7 @@ static bool readable(const char *filename) {
/* Path can't/shouldn't contain embedded zeros */
static const char *get_next_template(klisp_State *K, const char *path,
- TValue *next) {
+ TValue *next) {
const char *l;
while (*path == *KLISP_PATHSEP) path++; /* skip separators */
if (*path == '\0') return NULL; /* no more templates */
@@ -807,8 +807,8 @@ static TValue str_sub(klisp_State *K, TValue s, TValue p, TValue r)
/* first calculate needed size */
while ((wild = strstr(sp, pp)) != NULL) {
- size += diff_size;
- sp = wild + psize;
+ size += diff_size;
+ sp = wild + psize;
}
/* now construct result buffer and fill it */
@@ -816,21 +816,21 @@ static TValue str_sub(klisp_State *K, TValue s, TValue p, TValue r)
char *resp = kstring_buf(res);
sp = kstring_buf(s);
while ((wild = strstr(sp, pp)) != NULL) {
- ptrdiff_t l = wild - sp;
- memcpy(resp, sp, l);
- resp += l;
- memcpy(resp, rp, rsize);
- resp += rsize;
- sp = wild + psize;
+ ptrdiff_t l = wild - sp;
+ memcpy(resp, sp, l);
+ resp += l;
+ memcpy(resp, rp, rsize);
+ resp += rsize;
+ sp = wild + psize;
}
strcpy(resp, sp); /* the size was calculated beforehand */
return res;
}
static TValue find_file (klisp_State *K, TValue name, TValue pname) {
- /* not used in klisp */
- /* name = luaL_gsub(L, name, ".", LUA_DIRSEP); */
- /* lua_getfield(L, LUA_ENVIRONINDEX, pname); */
+ /* not used in klisp */
+ /* name = luaL_gsub(L, name, ".", LUA_DIRSEP); */
+ /* lua_getfield(L, LUA_ENVIRONINDEX, pname); */
klisp_assert(ttisstring(name) && !kstring_emptyp(name));
const char *path = kstring_buf(pname);
TValue next = K->empty_string;
@@ -839,12 +839,12 @@ static TValue find_file (klisp_State *K, TValue name, TValue pname) {
krooted_tvs_push(K, wild);
while ((path = get_next_template(K, path, &next)) != NULL) {
- next = str_sub(K, next, wild, name);
- if (readable(kstring_buf(next))) { /* does file exist and is readable? */
- krooted_tvs_pop(K);
- krooted_vars_pop(K);
- return next; /* return that file name */
- }
+ next = str_sub(K, next, wild, name);
+ if (readable(kstring_buf(next))) { /* does file exist and is readable? */
+ krooted_tvs_pop(K);
+ krooted_vars_pop(K);
+ return next; /* return that file name */
+ }
}
krooted_tvs_pop(K);
@@ -873,21 +873,21 @@ void require(klisp_State *K)
bind_1tp(K, ptree, "string", ttisstring, name);
if (kstring_emptyp(name)) {
- klispE_throw_simple(K, "Empty name");
- return;
+ klispE_throw_simple(K, "Empty name");
+ return;
}
/* search for the named file in the table of already
required files.
N.B. this will be fooled if the same file is accessed
through different names */
TValue saved_name = kstring_immutablep(name)? name :
- kstring_new_bs_imm(K, kstring_buf(name), kstring_size(name));
+ kstring_new_bs_imm(K, kstring_buf(name), kstring_size(name));
const TValue *node = klispH_getstr(tv2table(K->require_table),
- tv2str(saved_name));
+ tv2str(saved_name));
if (!ttisfree(*node)) {
- /* was required already, nothing to be done */
- kapply_cc(K, KINERT);
+ /* was required already, nothing to be done */
+ kapply_cc(K, KINERT);
}
krooted_tvs_push(K, saved_name);
@@ -896,8 +896,8 @@ void require(klisp_State *K)
filename = find_file(K, name, K->require_path);
if (kstring_emptyp(filename)) {
- klispE_throw_simple_with_irritants(K, "Not found", 1, name);
- return;
+ klispE_throw_simple_with_irritants(K, "Not found", 1, name);
+ return;
}
/* the file was found, save it in the table */
@@ -907,25 +907,25 @@ void require(klisp_State *K)
sate of the require in the table, so we could have: error, required,
requiring, etc */
*(klispH_setstr(K, tv2table(K->require_table), tv2str(saved_name))) =
- KTRUE;
+ KTRUE;
krooted_tvs_pop(K); /* saved_name no longer necessary */
/* the reads must be guarded to close the file if there is some error
- this continuation also will return inert after the evaluation of the
- last expression is done */
+ this continuation also will return inert after the evaluation of the
+ last expression is done */
TValue port = kmake_fport(K, filename, false, false);
krooted_tvs_push(K, port);
krooted_vars_pop(K); /* filename already rooted */
TValue inert_cont = kmake_continuation(K, kget_cc(K), do_return_value, 1,
- KINERT);
+ KINERT);
krooted_tvs_push(K, inert_cont);
TValue guarded_cont = make_guarded_read_cont(K, kget_cc(K), port);
/* this will be used later, but contruct it now to use the
current continuation as parent
- GC: root this obj */
+ GC: root this obj */
kset_cc(K, guarded_cont); /* implicit rooting */
/* any error will close the port */
TValue ls = kread_list_from_port(K, port, false); /* immutable pairs */
@@ -936,28 +936,28 @@ void require(klisp_State *K)
krooted_tvs_pop(K); /* already rooted */
if (ttisnil(ls)) {
- krooted_tvs_pop(K); /* port */
- kapply_cc(K, KINERT);
+ krooted_tvs_pop(K); /* port */
+ kapply_cc(K, KINERT);
} else {
- TValue tail = kcdr(ls);
- /* std environments have hashtable for bindings */
- TValue env = kmake_table_environment(K, K->ground_env);
- if (ttispair(tail)) {
- krooted_tvs_push(K, ls);
- krooted_tvs_push(K, env);
- TValue new_cont = kmake_continuation(K, kget_cc(K),
- do_seq, 2, tail, env);
- kset_cc(K, new_cont);
+ TValue tail = kcdr(ls);
+ /* std environments have hashtable for bindings */
+ TValue env = kmake_table_environment(K, K->ground_env);
+ if (ttispair(tail)) {
+ krooted_tvs_push(K, ls);
+ krooted_tvs_push(K, env);
+ TValue new_cont = kmake_continuation(K, kget_cc(K),
+ do_seq, 2, tail, env);
+ kset_cc(K, new_cont);
#if KTRACK_SI
- /* put the source info of the list including the element
- that we are about to evaluate */
- kset_source_info(K, new_cont, ktry_get_si(K, ls));
+ /* put the source info of the list including the element
+ that we are about to evaluate */
+ kset_source_info(K, new_cont, ktry_get_si(K, ls));
#endif
- krooted_tvs_pop(K); /* env */
- krooted_tvs_pop(K); /* ls */
- }
- krooted_tvs_pop(K); /* port */
- ktail_eval(K, kcar(ls), env);
+ krooted_tvs_pop(K); /* env */
+ krooted_tvs_pop(K); /* ls */
+ }
+ krooted_tvs_pop(K); /* port */
+ ktail_eval(K, kcar(ls), env);
}
}
@@ -966,18 +966,18 @@ void registered_requirementP(klisp_State *K)
{
bind_1tp(K, K->next_value, "string", ttisstring, name);
if (kstring_emptyp(name)) {
- klispE_throw_simple(K, "Empty name");
- return;
+ klispE_throw_simple(K, "Empty name");
+ return;
}
/* search for the named file in the table of already
required files.
N.B. this will be fooled if the same file is accessed
through different names */
TValue saved_name = kstring_immutablep(name)? name :
- kstring_new_bs_imm(K, kstring_buf(name), kstring_size(name));
+ kstring_new_bs_imm(K, kstring_buf(name), kstring_size(name));
const TValue *node = klispH_getstr(tv2table(K->require_table),
- tv2str(saved_name));
+ tv2str(saved_name));
kapply_cc(K, ttisfree(*node)? KFALSE : KTRUE);
}
@@ -985,11 +985,11 @@ void register_requirementB(klisp_State *K)
{
bind_1tp(K, K->next_value, "string", ttisstring, name);
if (kstring_emptyp(name)) {
- klispE_throw_simple(K, "Empty name");
- return;
+ klispE_throw_simple(K, "Empty name");
+ return;
}
TValue saved_name = kstring_immutablep(name)? name :
- kstring_new_bs_imm(K, kstring_buf(name), kstring_size(name));
+ kstring_new_bs_imm(K, kstring_buf(name), kstring_size(name));
/* don't throw error if already registered */
*(klispH_setstr(K, tv2table(K->require_table),
@@ -1001,11 +1001,11 @@ void unregister_requirementB(klisp_State *K)
{
bind_1tp(K, K->next_value, "string", ttisstring, name);
if (kstring_emptyp(name)) {
- klispE_throw_simple(K, "Empty name");
- return;
+ klispE_throw_simple(K, "Empty name");
+ return;
}
TValue saved_name = kstring_immutablep(name)? name :
- kstring_new_bs_imm(K, kstring_buf(name), kstring_size(name));
+ kstring_new_bs_imm(K, kstring_buf(name), kstring_size(name));
/* don't throw error if not registered */
*(klispH_setstr(K, tv2table(K->require_table),
@@ -1018,14 +1018,14 @@ void find_required_filename(klisp_State *K)
{
bind_1tp(K, K->next_value, "string", ttisstring, name);
if (kstring_emptyp(name)) {
- klispE_throw_simple(K, "Empty name");
- return;
+ klispE_throw_simple(K, "Empty name");
+ return;
}
TValue filename = find_file(K, name, K->require_path);
if (kstring_emptyp(filename)) {
- klispE_throw_simple_with_irritants(K, "Not found", 1, name);
- return;
+ klispE_throw_simple_with_irritants(K, "Not found", 1, name);
+ return;
}
kapply_cc(K, filename);
}
@@ -1040,7 +1040,7 @@ void get_module(klisp_State *K)
UNUSED(xparams);
UNUSED(denv);
bind_al1tp(K, ptree, "string", ttisstring, filename,
- maybe_env);
+ maybe_env);
TValue port = kmake_fport(K, filename, false, false);
krooted_tvs_push(K, port);
@@ -1051,17 +1051,17 @@ void get_module(klisp_State *K)
krooted_tvs_push(K, env);
if (get_opt_tpar(K, maybe_env, "environment", ttisenvironment)) {
- kadd_binding(K, env, K->module_params_sym, maybe_env);
+ kadd_binding(K, env, K->module_params_sym, maybe_env);
}
TValue ret_env_cont = kmake_continuation(K, kget_cc(K), do_return_value,
- 1, env);
+ 1, env);
krooted_tvs_pop(K); /* env alread in cont */
krooted_tvs_push(K, ret_env_cont);
/* the reads must be guarded to close the file if there is some error
- this continuation also will return inert after the evaluation of the
- last expression is done */
+ this continuation also will return inert after the evaluation of the
+ last expression is done */
TValue guarded_cont = make_guarded_read_cont(K, kget_cc(K), port);
kset_cc(K, guarded_cont); /* implicit roooting */
@@ -1075,24 +1075,24 @@ void get_module(klisp_State *K)
krooted_tvs_pop(K); /* implicitly rooted */
if (ttisnil(ls)) {
- krooted_tvs_pop(K); /* port */
- kapply_cc(K, KINERT);
+ krooted_tvs_pop(K); /* port */
+ kapply_cc(K, KINERT);
} else {
- TValue tail = kcdr(ls);
- if (ttispair(tail)) {
- krooted_tvs_push(K, ls);
- TValue new_cont = kmake_continuation(K, kget_cc(K),
- do_seq, 2, tail, env);
- kset_cc(K, new_cont);
+ TValue tail = kcdr(ls);
+ if (ttispair(tail)) {
+ krooted_tvs_push(K, ls);
+ TValue new_cont = kmake_continuation(K, kget_cc(K),
+ do_seq, 2, tail, env);
+ kset_cc(K, new_cont);
#if KTRACK_SI
- /* put the source info of the list including the element
- that we are about to evaluate */
- kset_source_info(K, new_cont, ktry_get_si(K, ls));
+ /* put the source info of the list including the element
+ that we are about to evaluate */
+ kset_source_info(K, new_cont, ktry_get_si(K, ls));
#endif
- krooted_tvs_pop(K);
- }
- krooted_tvs_pop(K); /* port */
- ktail_eval(K, kcar(ls), env);
+ krooted_tvs_pop(K);
+ }
+ krooted_tvs_pop(K); /* port */
+ ktail_eval(K, kcar(ls), env);
}
}
@@ -1107,21 +1107,21 @@ void display(klisp_State *K)
UNUSED(denv);
bind_al1tp(K, ptree, "any", anytype, obj,
- port);
+ port);
if (!get_opt_tpar(K, port, "port", ttisport)) {
- port = kcdr(K->kd_out_port_key); /* access directly */
+ port = kcdr(K->kd_out_port_key); /* access directly */
}
if (!kport_is_output(port)) {
- klispE_throw_simple(K, "the port should be an output port");
- return;
+ klispE_throw_simple(K, "the port should be an output port");
+ return;
} else if (!kport_is_textual(port)) {
- klispE_throw_simple(K, "the port should be a textual port");
- return;
+ klispE_throw_simple(K, "the port should be a textual port");
+ return;
} else if (kport_is_closed(port)) {
- klispE_throw_simple(K, "the port is already closed");
- return;
+ klispE_throw_simple(K, "the port is already closed");
+ return;
}
/* true: don't quote strings, don't escape chars */
@@ -1141,18 +1141,18 @@ void read_line(klisp_State *K)
TValue port = ptree;
if (!get_opt_tpar(K, port, "port", ttisport)) {
- port = kcdr(K->kd_in_port_key); /* access directly */
+ port = kcdr(K->kd_in_port_key); /* access directly */
}
if (!kport_is_input(port)) {
- klispE_throw_simple(K, "the port should be an input port");
- return;
+ klispE_throw_simple(K, "the port should be an input port");
+ return;
} else if (!kport_is_textual(port)) {
- klispE_throw_simple(K, "the port should be a textual port");
- return;
+ klispE_throw_simple(K, "the port should be a textual port");
+ return;
} else if (kport_is_closed(port)) {
- klispE_throw_simple(K, "the port is already closed");
- return;
+ klispE_throw_simple(K, "the port is already closed");
+ return;
}
TValue obj = kread_line_from_port(K, port);
@@ -1172,17 +1172,17 @@ void flush(klisp_State *K)
TValue port = ptree;
if (!get_opt_tpar(K, port, "port", ttisport)) {
- port = kcdr(K->kd_out_port_key); /* access directly */
+ port = kcdr(K->kd_out_port_key); /* access directly */
}
if (!kport_is_output(port)) {
- klispE_throw_simple(K, "the port should be an output port");
- return;
+ klispE_throw_simple(K, "the port should be an output port");
+ return;
}
if (kport_is_closed(port)) {
- klispE_throw_simple(K, "the port is already closed");
- return;
+ klispE_throw_simple(K, "the port is already closed");
+ return;
}
kwrite_flush_port(K, port);
@@ -1201,85 +1201,85 @@ void kinit_ports_ground_env(klisp_State *K)
/* 15.1.1 port? */
add_applicative(K, ground_env, "port?", ftypep, 2, symbol,
- p2tv(kportp));
+ p2tv(kportp));
/* 15.1.2 input-port?, output-port? */
add_applicative(K, ground_env, "input-port?", ftypep, 2, symbol,
- p2tv(kinput_portp));
+ p2tv(kinput_portp));
add_applicative(K, ground_env, "output-port?", ftypep, 2, symbol,
- p2tv(koutput_portp));
+ p2tv(koutput_portp));
/* 15.1.? binary-port?, textual-port? */
add_applicative(K, ground_env, "binary-port?", ftypep, 2, symbol,
- p2tv(kbinary_portp));
+ p2tv(kbinary_portp));
add_applicative(K, ground_env, "textual-port?", ftypep, 2, symbol,
- p2tv(ktextual_portp));
+ p2tv(ktextual_portp));
/* 15.1.2 file-port?, string-port?, bytevector-port? */
add_applicative(K, ground_env, "file-port?", ftypep, 2, symbol,
- p2tv(kfile_portp));
+ p2tv(kfile_portp));
add_applicative(K, ground_env, "string-port?", ftypep, 2, symbol,
- p2tv(kstring_portp));
+ p2tv(kstring_portp));
add_applicative(K, ground_env, "bytevector-port?", ftypep, 2, symbol,
- p2tv(kbytevector_portp));
+ p2tv(kbytevector_portp));
/* 15.1.? port-open? */
add_applicative(K, ground_env, "port-open?", ftyped_predp, 3, symbol,
- p2tv(kportp), p2tv(kport_openp));
+ p2tv(kportp), p2tv(kport_openp));
/* 15.1.3 with-input-from-file, with-ouput-to-file */
/* 15.1.? with-error-to-file */
add_applicative(K, ground_env, "with-input-from-file", with_file,
- 3, symbol, b2tv(false), K->kd_in_port_key);
+ 3, symbol, b2tv(false), K->kd_in_port_key);
add_applicative(K, ground_env, "with-output-to-file", with_file,
- 3, symbol, b2tv(true), K->kd_out_port_key);
+ 3, symbol, b2tv(true), K->kd_out_port_key);
add_applicative(K, ground_env, "with-error-to-file", with_file,
- 3, symbol, b2tv(true), K->kd_error_port_key);
+ 3, symbol, b2tv(true), K->kd_error_port_key);
/* 15.1.4 get-current-input-port, get-current-output-port */
/* 15.1.? get-current-error-port */
add_applicative(K, ground_env, "get-current-input-port", get_current_port,
- 2, symbol, K->kd_in_port_key);
+ 2, symbol, K->kd_in_port_key);
add_applicative(K, ground_env, "get-current-output-port", get_current_port,
- 2, symbol, K->kd_out_port_key);
+ 2, symbol, K->kd_out_port_key);
add_applicative(K, ground_env, "get-current-error-port", get_current_port,
- 2, symbol, K->kd_error_port_key);
+ 2, symbol, K->kd_error_port_key);
/* 15.1.5 open-input-file, open-output-file */
add_applicative(K, ground_env, "open-input-file", open_file, 2,
- b2tv(false), b2tv(false));
+ b2tv(false), b2tv(false));
add_applicative(K, ground_env, "open-output-file", open_file, 2,
- b2tv(true), b2tv(false));
+ b2tv(true), b2tv(false));
/* 15.1.? open-binary-input-file, open-binary-output-file */
add_applicative(K, ground_env, "open-binary-input-file", open_file, 2,
- b2tv(false), b2tv(true));
+ b2tv(false), b2tv(true));
add_applicative(K, ground_env, "open-binary-output-file", open_file, 2,
- b2tv(true), b2tv(true));
+ b2tv(true), b2tv(true));
/* 15.1.? open-input-string, open-output-string */
/* 15.1.? open-input-bytevector, open-output-bytevector */
add_applicative(K, ground_env, "open-input-string", open_mport, 2,
- b2tv(false), b2tv(false));
+ b2tv(false), b2tv(false));
add_applicative(K, ground_env, "open-output-string", open_mport, 2,
- b2tv(true), b2tv(false));
+ b2tv(true), b2tv(false));
add_applicative(K, ground_env, "open-input-bytevector", open_mport, 2,
- b2tv(false), b2tv(true));
+ b2tv(false), b2tv(true));
add_applicative(K, ground_env, "open-output-bytevector", open_mport, 2,
- b2tv(true), b2tv(true));
+ b2tv(true), b2tv(true));
/* 15.1.6 close-input-file, close-output-file */
/* ASK John: should this be called close-input-port & close-ouput-port
like in r5rs? that doesn't seem consistent with open thou */
add_applicative(K, ground_env, "close-input-file", close_file, 1,
- b2tv(false));
+ b2tv(false));
add_applicative(K, ground_env, "close-output-file", close_file, 1,
- b2tv(true));
+ b2tv(true));
/* 15.1.? Use the r7rs names, in preparation for other kind of ports */
add_applicative(K, ground_env, "close-input-port", close_port, 2,
- b2tv(true), b2tv(false));
+ b2tv(true), b2tv(false));
add_applicative(K, ground_env, "close-output-port", close_port, 2,
- b2tv(false), b2tv(true));
+ b2tv(false), b2tv(true));
add_applicative(K, ground_env, "close-port", close_port, 2,
- b2tv(false), b2tv(false));
+ b2tv(false), b2tv(false));
/* 15.1.? get-output-string, get-output-bytevector */
add_applicative(K, ground_env, "get-output-string", get_output_buffer, 1,
- b2tv(false));
+ b2tv(false));
add_applicative(K, ground_env, "get-output-bytevector", get_output_buffer,
- 1, b2tv(true));
+ 1, b2tv(true));
/* 15.1.7 read */
add_applicative(K, ground_env, "read", gread, 0);
@@ -1290,17 +1290,17 @@ void kinit_ports_ground_env(klisp_State *K)
/* 15.1.? eof-object? */
add_applicative(K, ground_env, "eof-object?", typep, 2, symbol,
- i2tv(K_TEOF));
+ i2tv(K_TEOF));
/* 15.1.? newline */
add_applicative(K, ground_env, "newline", newline, 0);
/* 15.1.? write-char */
add_applicative(K, ground_env, "write-char", write_char, 0);
/* 15.1.? read-char */
add_applicative(K, ground_env, "read-char", read_peek_char, 1,
- b2tv(false));
+ b2tv(false));
/* 15.1.? peek-char */
add_applicative(K, ground_env, "peek-char", read_peek_char, 1,
- b2tv(true));
+ b2tv(true));
/* 15.1.? char-ready? */
/* XXX: this always return #t, proper behaviour requires platform
specific code (probably select for posix, a thread for windows
@@ -1311,10 +1311,10 @@ void kinit_ports_ground_env(klisp_State *K)
add_applicative(K, ground_env, "write-u8", write_u8, 0);
/* 15.1.? read-u8 */
add_applicative(K, ground_env, "read-u8", read_peek_u8, 1,
- b2tv(false));
+ b2tv(false));
/* 15.1.? peek-u8 */
add_applicative(K, ground_env, "peek-u8", read_peek_u8, 1,
- b2tv(true));
+ b2tv(true));
/* 15.1.? u8-ready? */
/* XXX: this always return #t, proper behaviour requires platform
specific code (probably select for posix, a thread for windows
@@ -1323,9 +1323,9 @@ void kinit_ports_ground_env(klisp_State *K)
add_applicative(K, ground_env, "u8-ready?", u8_readyp, 0);
/* 15.2.1 call-with-input-file, call-with-output-file */
add_applicative(K, ground_env, "call-with-input-file", call_with_file,
- 2, symbol, b2tv(false));
+ 2, symbol, b2tv(false));
add_applicative(K, ground_env, "call-with-output-file", call_with_file,
- 2, symbol, b2tv(true));
+ 2, symbol, b2tv(true));
/* 15.2.2 load */
add_applicative(K, ground_env, "load", load, 0);
/* 15.2.? require */
diff --git a/src/kgpromises.c b/src/kgpromises.c
@@ -42,29 +42,29 @@ void do_handle_result(klisp_State *K)
/* check to see if promise was determined before the eval completed */
if (ttisnil(kpromise_maybe_env(prom))) {
- /* discard obj, return previous result */
- kapply_cc(K, kpromise_exp(prom));
+ /* discard obj, return previous result */
+ kapply_cc(K, kpromise_exp(prom));
} else if (ttispromise(obj)) {
- /* force iteratively, by sharing pairs so that when obj
- determines a value, prom also does */
- TValue node = kpromise_node(obj);
- kpromise_node(prom) = node;
- TValue expr = kpromise_exp(prom);
- TValue maybe_env = kpromise_maybe_env(prom);
- if (ttisnil(maybe_env)) {
- /* promise was already determined */
- kapply_cc(K, expr);
- } else {
- TValue new_cont = kmake_continuation(K, kget_cc(K),
- do_handle_result, 1, prom);
- kset_cc(K, new_cont);
- ktail_eval(K, expr, maybe_env);
- }
+ /* force iteratively, by sharing pairs so that when obj
+ determines a value, prom also does */
+ TValue node = kpromise_node(obj);
+ kpromise_node(prom) = node;
+ TValue expr = kpromise_exp(prom);
+ TValue maybe_env = kpromise_maybe_env(prom);
+ if (ttisnil(maybe_env)) {
+ /* promise was already determined */
+ kapply_cc(K, expr);
+ } else {
+ TValue new_cont = kmake_continuation(K, kget_cc(K),
+ do_handle_result, 1, prom);
+ kset_cc(K, new_cont);
+ ktail_eval(K, expr, maybe_env);
+ }
} else {
- /* memoize result */
- TValue node = kpromise_node(prom);
- kset_car(node, obj);
- kset_cdr(node, KNIL);
+ /* memoize result */
+ TValue node = kpromise_node(prom);
+ kset_car(node, obj);
+ kset_cdr(node, KNIL);
}
}
@@ -79,18 +79,18 @@ void force(klisp_State *K)
UNUSED(denv);
bind_1p(K, ptree, obj);
if (!ttispromise(obj)) {
- /* non promises force to themselves */
- kapply_cc(K, obj);
+ /* non promises force to themselves */
+ kapply_cc(K, obj);
} else if (ttisnil(kpromise_maybe_env(obj))) {
- /* promise was already determined */
- kapply_cc(K, kpromise_exp(obj));
+ /* promise was already determined */
+ kapply_cc(K, kpromise_exp(obj));
} else {
- TValue expr = kpromise_exp(obj);
- TValue env = kpromise_maybe_env(obj);
- TValue new_cont = kmake_continuation(K, kget_cc(K), do_handle_result,
- 1, obj);
- kset_cc(K, new_cont);
- ktail_eval(K, expr, env);
+ TValue expr = kpromise_exp(obj);
+ TValue env = kpromise_maybe_env(obj);
+ TValue new_cont = kmake_continuation(K, kget_cc(K), do_handle_result,
+ 1, obj);
+ kset_cc(K, new_cont);
+ ktail_eval(K, expr, env);
}
}
@@ -138,7 +138,7 @@ void kinit_promises_ground_env(klisp_State *K)
/* 9.1.1 promise? */
add_applicative(K, ground_env, "promise?", typep, 2, symbol,
- i2tv(K_TPROMISE));
+ i2tv(K_TPROMISE));
/* 9.1.2 force */
add_applicative(K, ground_env, "force", force, 0);
/* 9.1.3 $lazy */
diff --git a/src/kgstrings.c b/src/kgstrings.c
@@ -43,18 +43,18 @@ void make_string(klisp_State *K)
UNUSED(xparams);
UNUSED(denv);
bind_al1tp(K, ptree, "exact integer", keintegerp, tv_s,
- maybe_char);
+ maybe_char);
char fill = ' ';
if (get_opt_tpar(K, maybe_char, "char", ttischar))
- fill = chvalue(maybe_char);
+ fill = chvalue(maybe_char);
if (knegativep(tv_s)) {
- klispE_throw_simple(K, "negative size");
- return;
+ klispE_throw_simple(K, "negative size");
+ return;
} else if (!ttisfixint(tv_s)) {
- klispE_throw_simple(K, "size is too big");
- return;
+ klispE_throw_simple(K, "size is too big");
+ return;
}
TValue new_str = kstring_new_sf(K, ivalue(tv_s), fill);
@@ -86,19 +86,19 @@ void string_ref(klisp_State *K)
UNUSED(xparams);
UNUSED(denv);
bind_2tp(K, ptree, "string", ttisstring, str,
- "exact integer", keintegerp, tv_i);
+ "exact integer", keintegerp, tv_i);
if (!ttisfixint(tv_i)) {
- /* TODO show index */
- klispE_throw_simple(K, "index out of bounds");
- return;
+ /* TODO show index */
+ klispE_throw_simple(K, "index out of bounds");
+ return;
}
int32_t i = ivalue(tv_i);
if (i < 0 || i >= kstring_size(str)) {
- /* TODO show index */
- klispE_throw_simple(K, "index out of bounds");
- return;
+ /* TODO show index */
+ klispE_throw_simple(K, "index out of bounds");
+ return;
}
TValue res = ch2tv(kstring_buf(str)[i]);
@@ -115,23 +115,23 @@ void string_setB(klisp_State *K)
UNUSED(xparams);
UNUSED(denv);
bind_3tp(K, ptree, "string", ttisstring, str,
- "exact integer", keintegerp, tv_i, "char", ttischar, tv_ch);
+ "exact integer", keintegerp, tv_i, "char", ttischar, tv_ch);
if (!ttisfixint(tv_i)) {
- /* TODO show index */
- klispE_throw_simple(K, "index out of bounds");
- return;
+ /* TODO show index */
+ klispE_throw_simple(K, "index out of bounds");
+ return;
} else if (kstring_immutablep(str)) {
- klispE_throw_simple(K, "immutable string");
- return;
+ klispE_throw_simple(K, "immutable string");
+ return;
}
int32_t i = ivalue(tv_i);
if (i < 0 || i >= kstring_size(str)) {
- /* TODO show index */
- klispE_throw_simple(K, "index out of bounds");
- return;
+ /* TODO show index */
+ klispE_throw_simple(K, "index out of bounds");
+ return;
}
kstring_buf(str)[i] = chvalue(tv_ch);
@@ -173,7 +173,7 @@ void kstring_change_case(klisp_State *K)
TValue res = kstring_new_bs(K, kstring_buf(str), size);
char *buf = kstring_buf(res);
for(int32_t i = 0; i < size; ++i, buf++) {
- *buf = fn(*buf);
+ *buf = fn(*buf);
}
kapply_cc(K, res);
}
@@ -192,17 +192,17 @@ void kstring_title_case(klisp_State *K)
char *buf = kstring_buf(res);
bool first = true;
while(size-- > 0) {
- char ch = *buf;
- if (ch == ' ')
- first = true;
- else if (!first)
- *buf = tolower(ch);
- else if (isalpha(ch)) {
+ char ch = *buf;
+ if (ch == ' ')
+ first = true;
+ else if (!first)
+ *buf = tolower(ch);
+ else if (isalpha(ch)) {
/* only count as first letter something that can be capitalized */
- *buf = toupper(ch);
- first = false;
- }
- ++buf;
+ *buf = toupper(ch);
+ first = false;
+ }
+ ++buf;
}
kapply_cc(K, res);
}
@@ -227,17 +227,17 @@ bool kstring_ci_eqp(TValue str1, TValue str2)
{
int32_t size = kstring_size(str1);
if (kstring_size(str2) != size)
- return false;
+ return false;
else {
- char *buf1 = kstring_buf(str1);
- char *buf2 = kstring_buf(str2);
-
- while(size--) {
- if (tolower(*buf1) != tolower(*buf2))
- return false;
- buf1++, buf2++;
- }
- return true;
+ char *buf1 = kstring_buf(str1);
+ char *buf2 = kstring_buf(str2);
+
+ while(size--) {
+ if (tolower(*buf1) != tolower(*buf2))
+ return false;
+ buf1++, buf2++;
+ }
+ return true;
}
}
@@ -266,12 +266,12 @@ bool kstring_ci_ltp(TValue str1, TValue str2)
char *buf2 = kstring_buf(str2);
while(min_size--) {
- int diff = (int) tolower(*buf1) - (int) tolower(*buf2);
- if (diff > 0)
- return false;
- else if (diff < 0)
- return true;
- buf1++, buf2++;
+ int diff = (int) tolower(*buf1) - (int) tolower(*buf2);
+ if (diff > 0)
+ return false;
+ else if (diff < 0)
+ return true;
+ buf1++, buf2++;
}
return size1 < size2;
}
@@ -304,40 +304,40 @@ void substring(klisp_State *K)
UNUSED(xparams);
UNUSED(denv);
bind_3tp(K, ptree, "string", ttisstring, str,
- "exact integer", keintegerp, tv_start,
- "exact integer", keintegerp, tv_end);
+ "exact integer", keintegerp, tv_start,
+ "exact integer", keintegerp, tv_end);
if (!ttisfixint(tv_start) || ivalue(tv_start) < 0 ||
- ivalue(tv_start) > kstring_size(str)) {
- /* TODO show index */
- klispE_throw_simple(K, "start index out of bounds");
- return;
+ ivalue(tv_start) > kstring_size(str)) {
+ /* TODO show index */
+ klispE_throw_simple(K, "start index out of bounds");
+ return;
}
int32_t start = ivalue(tv_start);
if (!ttisfixint(tv_end) || ivalue(tv_end) < 0 ||
- ivalue(tv_end) > kstring_size(str)) {
- klispE_throw_simple(K, "end index out of bounds");
- return;
+ ivalue(tv_end) > kstring_size(str)) {
+ klispE_throw_simple(K, "end index out of bounds");
+ return;
}
int32_t end = ivalue(tv_end);
if (start > end) {
- /* TODO show indexes */
- klispE_throw_simple(K, "end index is smaller than start index");
- return;
+ /* TODO show indexes */
+ klispE_throw_simple(K, "end index is smaller than start index");
+ return;
}
int32_t size = end - start;
TValue new_str;
/* the if isn't strictly necessary but it's clearer this way */
if (size == 0) {
- new_str = K->empty_string;
+ new_str = K->empty_string;
} else {
- /* always returns mutable strings */
- new_str = kstring_new_bs(K, kstring_buf(str)+start, size);
+ /* always returns mutable strings */
+ new_str = kstring_new_bs(K, kstring_buf(str)+start, size);
}
kapply_cc(K, new_str);
}
@@ -363,32 +363,32 @@ void string_append(klisp_State *K)
int32_t saved_pairs = pairs; /* save pairs for next loop */
TValue tail = ptree;
while(pairs--) {
- total_size += kstring_size(kcar(tail));
- if (total_size > INT32_MAX) {
- klispE_throw_simple(K, "resulting string is too big");
- return;
- }
- tail = kcdr(tail);
+ total_size += kstring_size(kcar(tail));
+ if (total_size > INT32_MAX) {
+ klispE_throw_simple(K, "resulting string is too big");
+ return;
+ }
+ tail = kcdr(tail);
}
/* this is safe */
int32_t size = (int32_t) total_size;
if (size == 0) {
- new_str = K->empty_string;
+ new_str = K->empty_string;
} else {
- new_str = kstring_new_s(K, size);
- char *buf = kstring_buf(new_str);
- /* loop again to copy the chars of each string */
- tail = ptree;
- pairs = saved_pairs;
-
- while(pairs--) {
- TValue first = kcar(tail);
- int32_t first_size = kstring_size(first);
- memcpy(buf, kstring_buf(first), first_size);
- buf += first_size;
- tail = kcdr(tail);
- }
+ new_str = kstring_new_s(K, size);
+ char *buf = kstring_buf(new_str);
+ /* loop again to copy the chars of each string */
+ tail = ptree;
+ pairs = saved_pairs;
+
+ while(pairs--) {
+ TValue first = kcar(tail);
+ int32_t first_size = kstring_size(first);
+ memcpy(buf, kstring_buf(first), first_size);
+ buf += first_size;
+ tail = kcdr(tail);
+ }
}
kapply_cc(K, new_str);
@@ -442,19 +442,19 @@ void string_to_vector(klisp_State *K)
TValue res;
if (kstring_emptyp(str)) {
- res = K->empty_vector;
+ res = K->empty_vector;
} else {
- uint32_t size = kstring_size(str);
-
- /* MAYBE add vector constructor without fill */
- /* no need to root this */
- res = kvector_new_sf(K, size, KINERT);
- char *src = kstring_buf(str);
- TValue *dst = kvector_buf(res);
- while(size--) {
- char ch = *src++; /* not needed but just in case */
- *dst++ = ch2tv(ch);
- }
+ uint32_t size = kstring_size(str);
+
+ /* MAYBE add vector constructor without fill */
+ /* no need to root this */
+ res = kvector_new_sf(K, size, KINERT);
+ char *src = kstring_buf(str);
+ TValue *dst = kvector_buf(res);
+ while(size--) {
+ char ch = *src++; /* not needed but just in case */
+ *dst++ = ch2tv(ch);
+ }
}
kapply_cc(K, res);
}
@@ -473,22 +473,22 @@ void vector_to_string(klisp_State *K)
TValue res;
if (kvector_emptyp(vec)) {
- res = K->empty_string;
+ res = K->empty_string;
} else {
- uint32_t size = kvector_size(vec);
-
- res = kstring_new_s(K, size); /* no need to root this */
- TValue *src = kvector_buf(vec);
- char *dst = kstring_buf(res);
- while(size--) {
- TValue tv = *src++;
- if (!ttischar(tv)) {
- klispE_throw_simple_with_irritants(K, "Non char object found",
- 1, tv);
- return;
- }
- *dst++ = chvalue(tv);
- }
+ uint32_t size = kvector_size(vec);
+
+ res = kstring_new_s(K, size); /* no need to root this */
+ TValue *src = kvector_buf(vec);
+ char *dst = kstring_buf(res);
+ while(size--) {
+ TValue tv = *src++;
+ if (!ttischar(tv)) {
+ klispE_throw_simple_with_irritants(K, "Non char object found",
+ 1, tv);
+ return;
+ }
+ *dst++ = chvalue(tv);
+ }
}
kapply_cc(K, res);
}
@@ -507,19 +507,19 @@ void string_to_bytevector(klisp_State *K)
TValue res;
if (kstring_emptyp(str)) {
- res = K->empty_bytevector;
+ res = K->empty_bytevector;
} else {
- uint32_t size = kstring_size(str);
+ uint32_t size = kstring_size(str);
- /* MAYBE add bytevector constructor without fill */
- /* no need to root this */
- res = kbytevector_new_s(K, size);
- char *src = kstring_buf(str);
- uint8_t *dst = kbytevector_buf(res);
+ /* MAYBE add bytevector constructor without fill */
+ /* no need to root this */
+ res = kbytevector_new_s(K, size);
+ char *src = kstring_buf(str);
+ uint8_t *dst = kbytevector_buf(res);
- while(size--) {
- *dst++ = (uint8_t)*src++;
- }
+ while(size--) {
+ *dst++ = (uint8_t)*src++;
+ }
}
kapply_cc(K, res);
}
@@ -538,21 +538,21 @@ void bytevector_to_string(klisp_State *K)
TValue res;
if (kbytevector_emptyp(bb)) {
- res = K->empty_string;
+ res = K->empty_string;
} else {
- uint32_t size = kbytevector_size(bb);
- res = kstring_new_s(K, size); /* no need to root this */
- uint8_t *src = kbytevector_buf(bb);
- char *dst = kstring_buf(res);
- while(size--) {
- uint8_t u8 = *src++;
- if (u8 >= 128) {
- klispE_throw_simple_with_irritants(K, "Char out of range",
- 1, i2tv(u8));
- return;
- }
- *dst++ = (char) u8;
- }
+ uint32_t size = kbytevector_size(bb);
+ res = kstring_new_s(K, size); /* no need to root this */
+ uint8_t *src = kbytevector_buf(bb);
+ char *dst = kstring_buf(res);
+ while(size--) {
+ uint8_t u8 = *src++;
+ if (u8 >= 128) {
+ klispE_throw_simple_with_irritants(K, "Char out of range",
+ 1, i2tv(u8));
+ return;
+ }
+ *dst++ = (char) u8;
+ }
}
kapply_cc(K, res);
}
@@ -572,9 +572,9 @@ void string_copy(klisp_State *K)
TValue new_str;
/* the if isn't strictly necessary but it's clearer this way */
if (tv_equal(str, K->empty_string)) {
- new_str = str;
+ new_str = str;
} else {
- new_str = kstring_new_bs(K, kstring_buf(str), kstring_size(str));
+ new_str = kstring_new_bs(K, kstring_buf(str), kstring_size(str));
}
kapply_cc(K, new_str);
}
@@ -592,9 +592,9 @@ void string_to_immutable_string(klisp_State *K)
TValue res_str;
if (kstring_immutablep(str)) {/* this includes the empty list */
- res_str = str;
+ res_str = str;
} else {
- res_str = kstring_new_bs_imm(K, kstring_buf(str), kstring_size(str));
+ res_str = kstring_new_bs_imm(K, kstring_buf(str), kstring_size(str));
}
kapply_cc(K, res_str);
}
@@ -609,11 +609,11 @@ void string_fillB(klisp_State *K)
UNUSED(xparams);
UNUSED(denv);
bind_2tp(K, ptree, "string", ttisstring, str,
- "char", ttischar, tv_ch);
+ "char", ttischar, tv_ch);
if (kstring_immutablep(str)) {
- klispE_throw_simple(K, "immutable string");
- return;
+ klispE_throw_simple(K, "immutable string");
+ return;
}
memset(kstring_buf(str), chvalue(tv_ch), kstring_size(str));
@@ -626,7 +626,7 @@ void kinit_strings_ground_env(klisp_State *K)
TValue ground_env = K->ground_env;
TValue symbol, value;
- /*
+ /*
** This section is still missing from the report. The bindings here are
** taken from r5rs scheme and should not be considered standard. They are
** provided in the meantime to allow programs to use string features
@@ -635,12 +635,12 @@ void kinit_strings_ground_env(klisp_State *K)
/* 13.1.1? string? */
add_applicative(K, ground_env, "string?", typep, 2, symbol,
- i2tv(K_TSTRING));
+ i2tv(K_TSTRING));
/* 13.? immutable-string?, mutable-string? */
add_applicative(K, ground_env, "immutable-string?", ftypep, 2, symbol,
- p2tv(kimmutable_stringp));
+ p2tv(kimmutable_stringp));
add_applicative(K, ground_env, "mutable-string?", ftypep, 2, symbol,
- p2tv(kmutable_stringp));
+ p2tv(kmutable_stringp));
/* 13.1.2? make-string */
add_applicative(K, ground_env, "make-string", make_string, 0);
/* 13.1.3? string-length */
@@ -654,35 +654,35 @@ void kinit_strings_ground_env(klisp_State *K)
/* 13.?? string-upcase, string-downcase, string-titlecase,
string-foldcase */
add_applicative(K, ground_env, "string-upcase", kstring_change_case, 1,
- p2tv(toupper));
+ p2tv(toupper));
add_applicative(K, ground_env, "string-downcase", kstring_change_case, 1,
- p2tv(tolower));
+ p2tv(tolower));
add_applicative(K, ground_env, "string-titlecase", kstring_title_case, 0);
add_applicative(K, ground_env, "string-foldcase", kstring_change_case, 1,
- p2tv(tolower));
+ p2tv(tolower));
/* 13.2.2? string=?, string-ci=? */
add_applicative(K, ground_env, "string=?", ftyped_bpredp, 3,
- symbol, p2tv(kstringp), p2tv(kstring_eqp));
+ symbol, p2tv(kstringp), p2tv(kstring_eqp));
add_applicative(K, ground_env, "string-ci=?", ftyped_bpredp, 3,
- symbol, p2tv(kstringp), p2tv(kstring_ci_eqp));
+ symbol, p2tv(kstringp), p2tv(kstring_ci_eqp));
/* 13.2.3? string<?, string<=?, string>?, string>=? */
add_applicative(K, ground_env, "string<?", ftyped_bpredp, 3,
- symbol, p2tv(kstringp), p2tv(kstring_ltp));
+ symbol, p2tv(kstringp), p2tv(kstring_ltp));
add_applicative(K, ground_env, "string<=?", ftyped_bpredp, 3,
- symbol, p2tv(kstringp), p2tv(kstring_lep));
+ symbol, p2tv(kstringp), p2tv(kstring_lep));
add_applicative(K, ground_env, "string>?", ftyped_bpredp, 3,
- symbol, p2tv(kstringp), p2tv(kstring_gtp));
+ symbol, p2tv(kstringp), p2tv(kstring_gtp));
add_applicative(K, ground_env, "string>=?", ftyped_bpredp, 3,
- symbol, p2tv(kstringp), p2tv(kstring_gep));
+ symbol, p2tv(kstringp), p2tv(kstring_gep));
/* 13.2.4? string-ci<?, string-ci<=?, string-ci>?, string-ci>=? */
add_applicative(K, ground_env, "string-ci<?", ftyped_bpredp, 3,
- symbol, p2tv(kstringp), p2tv(kstring_ci_ltp));
+ symbol, p2tv(kstringp), p2tv(kstring_ci_ltp));
add_applicative(K, ground_env, "string-ci<=?", ftyped_bpredp, 3,
- symbol, p2tv(kstringp), p2tv(kstring_ci_lep));
+ symbol, p2tv(kstringp), p2tv(kstring_ci_lep));
add_applicative(K, ground_env, "string-ci>?", ftyped_bpredp, 3,
- symbol, p2tv(kstringp), p2tv(kstring_ci_gtp));
+ symbol, p2tv(kstringp), p2tv(kstring_ci_gtp));
add_applicative(K, ground_env, "string-ci>=?", ftyped_bpredp, 3,
- symbol, p2tv(kstringp), p2tv(kstring_ci_gep));
+ symbol, p2tv(kstringp), p2tv(kstring_ci_gep));
/* 13.2.5? substring */
add_applicative(K, ground_env, "substring", substring, 0);
/* 13.2.6? string-append */
@@ -695,14 +695,14 @@ void kinit_strings_ground_env(klisp_State *K)
add_applicative(K, ground_env, "vector->string", vector_to_string, 0);
/* 13.?? string->bytevector, bytevector->string */
add_applicative(K, ground_env, "string->bytevector",
- string_to_bytevector, 0);
+ string_to_bytevector, 0);
add_applicative(K, ground_env, "bytevector->string",
- bytevector_to_string, 0);
+ bytevector_to_string, 0);
/* 13.2.8? string-copy */
add_applicative(K, ground_env, "string-copy", string_copy, 0);
/* 13.2.9? string->immutable-string */
add_applicative(K, ground_env, "string->immutable-string",
- string_to_immutable_string, 0);
+ string_to_immutable_string, 0);
/* 13.2.10? string-fill! */
add_applicative(K, ground_env, "string-fill!", string_fillB, 0);
diff --git a/src/kgsymbols.c b/src/kgsymbols.c
@@ -64,7 +64,7 @@ void kinit_symbols_ground_env(klisp_State *K)
/* 4.4.1 symbol? */
add_applicative(K, ground_env, "symbol?", typep, 2, symbol,
- i2tv(K_TSYMBOL));
+ i2tv(K_TSYMBOL));
/*
** This section is still missing from the report. The bindings here are
** taken from r5rs scheme and should not be considered standard.
diff --git a/src/kgsystem.c b/src/kgsystem.c
@@ -41,11 +41,11 @@ void current_second(klisp_State *K)
check_0p(K, ptree);
time_t now = time(NULL);
if (now == -1) {
- klispE_throw_simple(K, "couldn't get time");
- return;
+ klispE_throw_simple(K, "couldn't get time");
+ return;
} else {
- TValue res = kinteger_new_uint64(K, (uint64_t) now);
- kapply_cc(K, res);
+ TValue res = kinteger_new_uint64(K, (uint64_t) now);
+ kapply_cc(K, res);
}
}
@@ -82,8 +82,8 @@ void file_existsp(klisp_State *K)
TValue res = KFALSE;
FILE *file = fopen(kstring_buf(filename), "r");
if (file) {
- res = KTRUE;
- UNUSED(fclose(file));
+ res = KTRUE;
+ UNUSED(fclose(file));
}
kapply_cc(K, res);
}
@@ -108,8 +108,8 @@ void delete_file(klisp_State *K)
klispE_throw_errno_with_irritants(K, "remove", 1, filename);
return;
} else {
- kapply_cc(K, KINERT);
- return;
+ kapply_cc(K, KINERT);
+ return;
}
}
@@ -124,7 +124,7 @@ void rename_file(klisp_State *K)
UNUSED(denv);
bind_2tp(K, ptree, "string", ttisstring, old_filename,
- "string", ttisstring, new_filename);
+ "string", ttisstring, new_filename);
/* TEMP: this should probably be done in a operating system specific
manner, but this will do for now */
@@ -134,8 +134,8 @@ void rename_file(klisp_State *K)
klispE_throw_errno_with_irritants(K, "rename", 2, old_filename, new_filename);
return;
} else {
- kapply_cc(K, KINERT);
- return;
+ kapply_cc(K, KINERT);
+ return;
}
}
@@ -144,7 +144,7 @@ void get_arguments(klisp_State *K)
{
/*
** xparams[0]: immutable argument list
- */
+ */
TValue ptree = K->next_value;
TValue *xparams = K->next_xparams;
TValue denv = K->next_env;
@@ -171,9 +171,9 @@ void get_environment_variable(klisp_State *K)
/* I follow r7rs here, but should probably throw error */
TValue res;
if (str == NULL) {
- res = KFALSE;
+ res = KFALSE;
} else {
- res = kstring_new_b_imm(K, str);
+ res = kstring_new_b_imm(K, str);
}
kapply_cc(K, res);
}
@@ -182,7 +182,7 @@ void get_environment_variables(klisp_State *K)
{
/*
** xparams[0]: immutable variable list
- */
+ */
TValue ptree = K->next_value;
TValue *xparams = K->next_xparams;
TValue denv = K->next_env;
@@ -197,14 +197,14 @@ void get_environment_variables(klisp_State *K)
/* TODO test, if that doesn't work, try to find a way
avoiding taking extra params in main */
/* I think it's defined in unistd, but it needs to have __USE_GNU
- defined. The correct way to do that would be to define _GNU_SOURCE
- before including any system files... That's not so good for an
- embeddable interpreter, but it could be done in the makefile I guess */
+ defined. The correct way to do that would be to define _GNU_SOURCE
+ before including any system files... That's not so good for an
+ embeddable interpreter, but it could be done in the makefile I guess */
extern
#ifdef _WIN32
- __declspec(dllimport)
+__declspec(dllimport)
#endif
- char **environ;
+char **environ;
/* Helper for get-environment-variables */
TValue create_env_var_list(klisp_State *K)
@@ -217,15 +217,15 @@ TValue create_env_var_list(klisp_State *K)
/* TODO test, if that doesn't work, try to find a way
avoiding taking extra params in main */
for(char **env = environ; *env != NULL; ++env) {
- /* *env is of the form: "<name>=<value>", presumably, name can't have
- an equal sign! */
- char *eq = strchr(*env, '=');
- int name_len = eq - *env;
- klisp_assert(eq != NULL); /* shouldn't happen */
- var_name = kstring_new_bs_imm(K, *env, name_len);
- var_value = kstring_new_b_imm(K, *env + name_len + 1);
- TValue new_entry = kimm_cons(K, var_name, var_value);
- tail = kimm_cons(K, new_entry, tail);
+ /* *env is of the form: "<name>=<value>", presumably, name can't have
+ an equal sign! */
+ char *eq = strchr(*env, '=');
+ int name_len = eq - *env;
+ klisp_assert(eq != NULL); /* shouldn't happen */
+ var_name = kstring_new_bs_imm(K, *env, name_len);
+ var_value = kstring_new_b_imm(K, *env + name_len + 1);
+ TValue new_entry = kimm_cons(K, var_name, var_value);
+ tail = kimm_cons(K, new_entry, tail);
}
return tail;
}
@@ -242,7 +242,7 @@ void kinit_system_ground_env(klisp_State *K)
add_applicative(K, ground_env, "current-jiffy", current_jiffy, 0);
/* ??.?.? jiffies-per-second */
add_applicative(K, ground_env, "jiffies-per-second", jiffies_per_second,
- 0);
+ 0);
/* ?.? file-exists? */
add_applicative(K, ground_env, "file-exists?", file_existsp, 0);
/* ?.? delete-file */
@@ -253,12 +253,12 @@ void kinit_system_ground_env(klisp_State *K)
/* The value for these two will get set later by the interpreter */
/* ?.? get-script-arguments, get-interpreter-arguments */
add_applicative(K, ground_env, "get-script-arguments", get_arguments,
- 1, KNIL);
+ 1, KNIL);
add_applicative(K, ground_env, "get-interpreter-arguments", get_arguments,
- 1, KNIL);
+ 1, KNIL);
/* ?.? get-environment-variable, get-environment-variables */
add_applicative(K, ground_env, "get-environment-variable",
- get_environment_variable, 0);
+ get_environment_variable, 0);
add_applicative(K, ground_env, "get-environment-variables",
- get_environment_variables, 1, create_env_var_list(K));
+ get_environment_variables, 1, create_env_var_list(K));
}
diff --git a/src/kgvectors.c b/src/kgvectors.c
@@ -48,7 +48,7 @@ void make_vector(klisp_State *K)
return;
}
TValue new_vector = (ivalue(tv_s) == 0)?
- K->empty_vector
+ K->empty_vector
: kvector_new_sf(K, ivalue(tv_s), fill);
kapply_cc(K, new_vector);
}
@@ -127,7 +127,7 @@ void vector_copy(klisp_State *K)
bind_1tp(K, ptree, "vector", ttisvector, v);
TValue new_vector = kvector_emptyp(v)?
- v
+ v
: kvector_new_bs_g(K, true, kvector_buf(v), kvector_size(v));
kapply_cc(K, new_vector);
}
@@ -185,19 +185,19 @@ void bytevector_to_vector(klisp_State *K)
TValue res;
if (kbytevector_emptyp(str)) {
- res = K->empty_vector;
+ res = K->empty_vector;
} else {
- uint32_t size = kbytevector_size(str);
-
- /* MAYBE add vector constructor without fill */
- /* no need to root this */
- res = kvector_new_sf(K, size, KINERT);
- uint8_t *src = kbytevector_buf(str);
- TValue *dst = kvector_buf(res);
- while(size--) {
- uint8_t u8 = *src++; /* not needed but just in case */
- *dst++ = i2tv(u8);
- }
+ uint32_t size = kbytevector_size(str);
+
+ /* MAYBE add vector constructor without fill */
+ /* no need to root this */
+ res = kvector_new_sf(K, size, KINERT);
+ uint8_t *src = kbytevector_buf(str);
+ TValue *dst = kvector_buf(res);
+ while(size--) {
+ uint8_t u8 = *src++; /* not needed but just in case */
+ *dst++ = i2tv(u8);
+ }
}
kapply_cc(K, res);
}
@@ -216,22 +216,22 @@ void vector_to_bytevector(klisp_State *K)
TValue res;
if (kvector_emptyp(vec)) {
- res = K->empty_bytevector;
+ res = K->empty_bytevector;
} else {
- uint32_t size = kvector_size(vec);
-
- res = kbytevector_new_s(K, size); /* no need to root this */
- TValue *src = kvector_buf(vec);
- uint8_t *dst = kbytevector_buf(res);
- while(size--) {
- TValue tv = *src++;
- if (!ttisu8(tv)) {
- klispE_throw_simple_with_irritants(K, "Non u8 object found",
- 1, tv);
- return;
- }
- *dst++ = (uint8_t) ivalue(tv);
- }
+ uint32_t size = kvector_size(vec);
+
+ res = kbytevector_new_s(K, size); /* no need to root this */
+ TValue *src = kvector_buf(vec);
+ uint8_t *dst = kbytevector_buf(res);
+ while(size--) {
+ TValue tv = *src++;
+ if (!ttisu8(tv)) {
+ klispE_throw_simple_with_irritants(K, "Non u8 object found",
+ 1, tv);
+ return;
+ }
+ *dst++ = (uint8_t) ivalue(tv);
+ }
}
kapply_cc(K, res);
}
@@ -246,21 +246,21 @@ void vector_copyB(klisp_State *K)
UNUSED(xparams);
UNUSED(denv);
bind_2tp(K, ptree, "vector", ttisvector, vector1,
- "vector", ttisvector, vector2);
+ "vector", ttisvector, vector2);
if (kvector_immutablep(vector2)) {
- klispE_throw_simple(K, "immutable destination vector");
- return;
+ klispE_throw_simple(K, "immutable destination vector");
+ return;
} else if (kvector_size(vector1) > kvector_size(vector2)) {
- klispE_throw_simple(K, "destination vector is too small");
- return;
+ klispE_throw_simple(K, "destination vector is too small");
+ return;
}
if (!tv_equal(vector1, vector2) &&
- !tv_equal(vector1, K->empty_vector)) {
- memcpy(kvector_buf(vector2),
- kvector_buf(vector1),
- kvector_size(vector1) * sizeof(TValue));
+ !tv_equal(vector1, K->empty_vector)) {
+ memcpy(kvector_buf(vector2),
+ kvector_buf(vector1),
+ kvector_size(vector1) * sizeof(TValue));
}
kapply_cc(K, KINERT);
}
@@ -276,40 +276,40 @@ void vector_copy_partial(klisp_State *K)
UNUSED(xparams);
UNUSED(denv);
bind_3tp(K, ptree, "vector", ttisvector, vector,
- "exact integer", keintegerp, tv_start,
- "exact integer", keintegerp, tv_end);
+ "exact integer", keintegerp, tv_start,
+ "exact integer", keintegerp, tv_end);
if (!ttisfixint(tv_start) || ivalue(tv_start) < 0 ||
- ivalue(tv_start) > kvector_size(vector)) {
- /* TODO show index */
- klispE_throw_simple(K, "start index out of bounds");
- return;
+ ivalue(tv_start) > kvector_size(vector)) {
+ /* TODO show index */
+ klispE_throw_simple(K, "start index out of bounds");
+ return;
}
int32_t start = ivalue(tv_start);
if (!ttisfixint(tv_end) || ivalue(tv_end) < 0 ||
- ivalue(tv_end) > kvector_size(vector)) {
- klispE_throw_simple(K, "end index out of bounds");
- return;
+ ivalue(tv_end) > kvector_size(vector)) {
+ klispE_throw_simple(K, "end index out of bounds");
+ return;
}
int32_t end = ivalue(tv_end);
if (start > end) {
- /* TODO show indexes */
- klispE_throw_simple(K, "end index is smaller than start index");
- return;
+ /* TODO show indexes */
+ klispE_throw_simple(K, "end index is smaller than start index");
+ return;
}
int32_t size = end - start;
TValue new_vector;
/* the if isn't strictly necessary but it's clearer this way */
if (size == 0) {
- new_vector = K->empty_vector;
+ new_vector = K->empty_vector;
} else {
- new_vector = kvector_new_bs_g(K, true, kvector_buf(vector)
- + start, size);
+ new_vector = kvector_new_bs_g(K, true, kvector_buf(vector)
+ + start, size);
}
kapply_cc(K, new_vector);
}
@@ -324,64 +324,64 @@ void vector_copy_partialB(klisp_State *K)
UNUSED(xparams);
UNUSED(denv);
bind_al3tp(K, ptree, "vector", ttisvector, vector1,
- "exact integer", keintegerp, tv_start,
- "exact integer", keintegerp, tv_end,
- rest);
+ "exact integer", keintegerp, tv_start,
+ "exact integer", keintegerp, tv_end,
+ rest);
/* XXX: this will send wrong error msgs (bad number of arg) */
bind_2tp(K, rest,
- "vector", ttisvector, vector2,
- "exact integer", keintegerp, tv_start2);
+ "vector", ttisvector, vector2,
+ "exact integer", keintegerp, tv_start2);
if (!ttisfixint(tv_start) || ivalue(tv_start) < 0 ||
- ivalue(tv_start) > kvector_size(vector1)) {
- /* TODO show index */
- klispE_throw_simple(K, "start index out of bounds");
- return;
+ ivalue(tv_start) > kvector_size(vector1)) {
+ /* TODO show index */
+ klispE_throw_simple(K, "start index out of bounds");
+ return;
}
int32_t start = ivalue(tv_start);
if (!ttisfixint(tv_end) || ivalue(tv_end) < 0 ||
- ivalue(tv_end) > kvector_size(vector1)) {
- klispE_throw_simple(K, "end index out of bounds");
- return;
+ ivalue(tv_end) > kvector_size(vector1)) {
+ klispE_throw_simple(K, "end index out of bounds");
+ return;
}
int32_t end = ivalue(tv_end);
if (start > end) {
- /* TODO show indexes */
- klispE_throw_simple(K, "end index is smaller than start index");
- return;
+ /* TODO show indexes */
+ klispE_throw_simple(K, "end index is smaller than start index");
+ return;
}
int32_t size = end - start;
if (kvector_immutablep(vector2)) {
- klispE_throw_simple(K, "immutable destination vector");
- return;
+ klispE_throw_simple(K, "immutable destination vector");
+ return;
}
if (!ttisfixint(tv_start2) || ivalue(tv_start2) < 0 ||
- ivalue(tv_start2) > kvector_size(vector2)) {
- klispE_throw_simple(K, "to index out of bounds");
- return;
+ ivalue(tv_start2) > kvector_size(vector2)) {
+ klispE_throw_simple(K, "to index out of bounds");
+ return;
}
int32_t start2 = ivalue(tv_start2);
int64_t end2 = (int64_t) start2 + size;
if ((end2 > INT32_MAX) ||
- (((int32_t) end2) > kvector_size(vector2))) {
- klispE_throw_simple(K, "not enough space in destination");
- return;
+ (((int32_t) end2) > kvector_size(vector2))) {
+ klispE_throw_simple(K, "not enough space in destination");
+ return;
}
if (size > 0) {
- memcpy(kvector_buf(vector2) + start2,
- kvector_buf(vector1) + start,
- size * sizeof(TValue));
+ memcpy(kvector_buf(vector2) + start2,
+ kvector_buf(vector1) + start,
+ size * sizeof(TValue));
}
kapply_cc(K, KINERT);
}
@@ -396,17 +396,17 @@ void vector_fillB(klisp_State *K)
UNUSED(xparams);
UNUSED(denv);
bind_2tp(K, ptree, "vector", ttisvector, vector,
- "any", anytype, fill);
+ "any", anytype, fill);
if (kvector_immutablep(vector)) {
- klispE_throw_simple(K, "immutable vector");
- return;
+ klispE_throw_simple(K, "immutable vector");
+ return;
}
uint32_t size = kvector_size(vector);
TValue *buf = kvector_buf(vector);
while(size-- > 0) {
- *buf++ = fill;
+ *buf++ = fill;
}
kapply_cc(K, KINERT);
}
@@ -420,8 +420,8 @@ void vector_to_immutable_vector(klisp_State *K)
bind_1tp(K, ptree, "vector", ttisvector, v);
TValue res = kvector_immutablep(v)?
- v
- : kvector_new_bs_g(K, false, kvector_buf(v), kvector_size(v));
+ v
+ : kvector_new_bs_g(K, false, kvector_buf(v), kvector_size(v));
kapply_cc(K, res);
}
@@ -431,7 +431,7 @@ void kinit_vectors_ground_env(klisp_State *K)
TValue ground_env = K->ground_env;
TValue symbol, value;
- /*
+ /*
** This section is not in the report. The bindings here are
** taken from the r7rs scheme draft and should not be considered standard.
** They are provided in the meantime to allow programs to use vectors.
@@ -464,9 +464,9 @@ void kinit_vectors_ground_env(klisp_State *K)
/* ?.? vector->bytevector, bytevector->vector */
add_applicative(K, ground_env, "vector->bytevector",
- vector_to_bytevector, 0);
+ vector_to_bytevector, 0);
add_applicative(K, ground_env, "bytevector->vector",
- bytevector_to_vector, 0);
+ bytevector_to_vector, 0);
/* ?.? vector->string, string->vector */
/* in kgstrings.c */
@@ -476,15 +476,15 @@ void kinit_vectors_ground_env(klisp_State *K)
/* ?.? vector-copy-partial */
add_applicative(K, ground_env, "vector-copy-partial",
- vector_copy_partial, 0);
+ vector_copy_partial, 0);
/* ?.? vector-copy-partial! */
add_applicative(K, ground_env, "vector-copy-partial!",
- vector_copy_partialB, 0);
+ vector_copy_partialB, 0);
/* ?.? vector-fill! */
add_applicative(K, ground_env, "vector-fill!", vector_fillB, 0);
/* ?.? vector->immutable-vector */
add_applicative(K, ground_env, "vector->immutable-vector",
- vector_to_immutable_vector, 0);
+ vector_to_immutable_vector, 0);
}
diff --git a/src/kinteger.c b/src/kinteger.c
@@ -53,12 +53,12 @@ TValue kbigint_copy(klisp_State *K, TValue src)
/* this works for bigints & fixints, returns true if ok */
bool kinteger_read(klisp_State *K, char *buf, int32_t base, TValue *out,
- char **end)
+ char **end)
{
TValue res = kbigint_make_simple(K);
krooted_tvs_push(K, res);
bool ret_val = (mp_int_read_cstring(K, tv2bigint(res), base,
- buf, end) == MP_OK);
+ buf, end) == MP_OK);
krooted_tvs_pop(K);
*out = kbigint_try_fixint(K, res);
return ret_val;
@@ -74,11 +74,11 @@ int32_t kbigint_print_size(TValue tv_bigint, int32_t base)
/* this is used by write */
void kbigint_print_string(klisp_State *K, TValue tv_bigint, int32_t base,
- char *buf, int32_t limit)
+ char *buf, int32_t limit)
{
klisp_assert(ttisbigint(tv_bigint));
mp_result res = mp_int_to_string(K, tv2bigint(tv_bigint), base, buf,
- limit);
+ limit);
/* only possible error is truncation */
klisp_assert(res == MP_OK);
}
@@ -87,31 +87,31 @@ void kbigint_print_string(klisp_State *K, TValue tv_bigint, int32_t base,
bool kbigint_eqp(TValue tv_bigint1, TValue tv_bigint2)
{
return (mp_int_compare(tv2bigint(tv_bigint1),
- tv2bigint(tv_bigint2)) == 0);
+ tv2bigint(tv_bigint2)) == 0);
}
bool kbigint_ltp(TValue tv_bigint1, TValue tv_bigint2)
{
return (mp_int_compare(tv2bigint(tv_bigint1),
- tv2bigint(tv_bigint2)) < 0);
+ tv2bigint(tv_bigint2)) < 0);
}
bool kbigint_lep(TValue tv_bigint1, TValue tv_bigint2)
{
return (mp_int_compare(tv2bigint(tv_bigint1),
- tv2bigint(tv_bigint2)) <= 0);
+ tv2bigint(tv_bigint2)) <= 0);
}
bool kbigint_gtp(TValue tv_bigint1, TValue tv_bigint2)
{
return (mp_int_compare(tv2bigint(tv_bigint1),
- tv2bigint(tv_bigint2)) > 0);
+ tv2bigint(tv_bigint2)) > 0);
}
bool kbigint_gep(TValue tv_bigint1, TValue tv_bigint2)
{
return (mp_int_compare(tv2bigint(tv_bigint1),
- tv2bigint(tv_bigint2)) >= 0);
+ tv2bigint(tv_bigint2)) >= 0);
}
/*
@@ -162,13 +162,13 @@ TValue kbigint_div_mod(klisp_State *K, TValue n1, TValue n2, TValue *res_r)
/* Adjust q & r so that 0 <= r < |d| */
if (mp_int_compare_zero(r) < 0) {
- if (mp_int_compare_zero(d) < 0) {
- mp_int_sub(K, r, d, r);
- mp_int_add_value(K, q, 1, q);
- } else {
- mp_int_add(K, r, d, r);
- mp_int_sub_value(K, q, 1, q);
- }
+ if (mp_int_compare_zero(d) < 0) {
+ mp_int_sub(K, r, d, r);
+ mp_int_add_value(K, q, 1, q);
+ } else {
+ mp_int_add(K, r, d, r);
+ mp_int_sub_value(K, q, 1, q);
+ }
}
krooted_tvs_pop(K);
@@ -210,25 +210,25 @@ TValue kbigint_div0_mod0(klisp_State *K, TValue n1, TValue n2, TValue *res_r)
/* this checks 2r >= |d| (which is the same r >= |d/2|) */
if (mp_int_compare(two_r, abs_d) >= 0) {
- if (mp_int_compare_zero(d) < 0) {
- mp_int_add(K, r, d, r);
- mp_int_sub_value(K, q, 1, q);
- } else {
- mp_int_sub(K, r, d, r);
- mp_int_add_value(K, q, 1, q);
- }
+ if (mp_int_compare_zero(d) < 0) {
+ mp_int_add(K, r, d, r);
+ mp_int_sub_value(K, q, 1, q);
+ } else {
+ mp_int_sub(K, r, d, r);
+ mp_int_add_value(K, q, 1, q);
+ }
} else {
- UNUSED(mp_int_neg(K, abs_d, abs_d));
- /* this checks 2r < -|d| (which is the same r < |d/2|) */
- if (mp_int_compare(two_r, abs_d) < 0) {
- if (mp_int_compare_zero(d) < 0) {
- mp_int_sub(K, r, d, r);
- mp_int_add_value(K, q, 1, q);
- } else {
- mp_int_add(K, r, d, r);
- mp_int_sub_value(K, q, 1, q);
- }
- }
+ UNUSED(mp_int_neg(K, abs_d, abs_d));
+ /* this checks 2r < -|d| (which is the same r < |d/2|) */
+ if (mp_int_compare(two_r, abs_d) < 0) {
+ if (mp_int_compare_zero(d) < 0) {
+ mp_int_sub(K, r, d, r);
+ mp_int_add_value(K, q, 1, q);
+ } else {
+ mp_int_add(K, r, d, r);
+ mp_int_sub_value(K, q, 1, q);
+ }
+ }
}
krooted_tvs_pop(K);
@@ -263,14 +263,14 @@ bool kbigint_evenp(TValue tv_bigint)
TValue kbigint_abs(klisp_State *K, TValue tv_bigint)
{
if (kbigint_negativep(tv_bigint)) {
- TValue copy = kbigint_make_simple(K);
- krooted_tvs_push(K, copy);
- UNUSED(mp_int_abs(K, tv2bigint(tv_bigint), tv2bigint(copy)));
- krooted_tvs_pop(K);
- /* NOTE: this can never be a fixint if the parameter was a bigint */
- return copy;
+ TValue copy = kbigint_make_simple(K);
+ krooted_tvs_push(K, copy);
+ UNUSED(mp_int_abs(K, tv2bigint(tv_bigint), tv2bigint(copy)));
+ krooted_tvs_pop(K);
+ /* NOTE: this can never be a fixint if the parameter was a bigint */
+ return copy;
} else {
- return tv_bigint;
+ return tv_bigint;
}
}
@@ -306,8 +306,8 @@ TValue kinteger_new_uint64(klisp_State *K, uint64_t x)
uint8_t d[8];
for (int i = 7; i >= 0; i--) {
- d[i] = (x & 0xFF);
- x >>= 8;
+ d[i] = (x & 0xFF);
+ x >>= 8;
}
mp_int_read_unsigned(K, tv2bigint(res), d, 8);
diff --git a/src/kinteger.h b/src/kinteger.h
@@ -27,15 +27,15 @@ inline TValue kbigint_try_fixint(klisp_State *K, TValue n)
UNUSED(K);
Bigint *b = tv2bigint(n);
if (MP_USED(b) != 1)
- return n;
+ return n;
int64_t digit = (int64_t) *(MP_DIGITS(b));
if (MP_SIGN(b) == MP_NEG) digit = -digit;
if (kfit_int32_t(digit)) {
- /* n shouln't be reachable but the let the gc do its job */
- return i2tv((int32_t) digit);
+ /* n shouln't be reachable but the let the gc do its job */
+ return i2tv((int32_t) digit);
} else {
- return n;
+ return n;
}
}
@@ -50,39 +50,39 @@ TValue kbigint_copy(klisp_State *K, TValue src);
/* Create a stack allocated bigints from a fixint,
useful for mixed operations, relatively light weight compared
to creating it in the heap and burdening the gc */
-#define kbind_bigint(name, fixint) \
- int32_t (KUNIQUE_NAME(i)) = ivalue(fixint); \
- Bigint KUNIQUE_NAME(bigint); \
- (KUNIQUE_NAME(bigint)).single = ({ \
- int64_t temp = (KUNIQUE_NAME(i)); \
- (uint32_t) ((temp < 0)? -temp : temp); \
- }); \
+#define kbind_bigint(name, fixint) \
+ int32_t (KUNIQUE_NAME(i)) = ivalue(fixint); \
+ Bigint KUNIQUE_NAME(bigint); \
+ (KUNIQUE_NAME(bigint)).single = ({ \
+ int64_t temp = (KUNIQUE_NAME(i)); \
+ (uint32_t) ((temp < 0)? -temp : temp); \
+ }); \
(KUNIQUE_NAME(bigint)).digits = &((KUNIQUE_NAME(bigint)).single); \
- (KUNIQUE_NAME(bigint)).alloc = 1; \
- (KUNIQUE_NAME(bigint)).used = 1; \
- (KUNIQUE_NAME(bigint)).sign = (KUNIQUE_NAME(i)) < 0? \
- MP_NEG : MP_ZPOS; \
+ (KUNIQUE_NAME(bigint)).alloc = 1; \
+ (KUNIQUE_NAME(bigint)).used = 1; \
+ (KUNIQUE_NAME(bigint)).sign = (KUNIQUE_NAME(i)) < 0? \
+ MP_NEG : MP_ZPOS; \
Bigint *name = &(KUNIQUE_NAME(bigint))
/* This can be used prior to calling a bigint functions
to automatically convert fixints to bigints.
NOTE: calls to this macro should go in different lines! */
-#define kensure_bigint(n) \
- /* must use goto, no block should be entered before calling \
- kbind_bigint */ \
- if (!ttisfixint(n)) \
- goto KUNIQUE_NAME(exit_lbl); \
- kbind_bigint(KUNIQUE_NAME(bint), (n)); \
- (n) = gc2bigint(KUNIQUE_NAME(bint)); \
- KUNIQUE_NAME(exit_lbl):
+#define kensure_bigint(n) \
+ /* must use goto, no block should be entered before calling \
+ kbind_bigint */ \
+ if (!ttisfixint(n)) \
+ goto KUNIQUE_NAME(exit_lbl); \
+ kbind_bigint(KUNIQUE_NAME(bint), (n)); \
+ (n) = gc2bigint(KUNIQUE_NAME(bint)); \
+KUNIQUE_NAME(exit_lbl):
/* This is used by the reader to destructively add digits to a number
- tv_bigint must be positive */
+ tv_bigint must be positive */
void kbigint_add_digit(klisp_State *K, TValue tv_bigint, int32_t base,
- int32_t digit);
+ int32_t digit);
/* This is used by the writer to get the digits of a number
- tv_bigint must be positive */
+ tv_bigint must be positive */
int32_t kbigint_remove_digit(klisp_State *K, TValue tv_bigint, int32_t base);
/* This is used by write to test if there is any digit left to print */
@@ -96,7 +96,7 @@ void kbigint_invert_sign(klisp_State *K, TValue tv_bigint);
/* this works for bigints & fixints, returns true if ok */
/* only positive numbers? */
bool kinteger_read(klisp_State *K, char *buf, int32_t base, TValue *out,
- char **end);
+ char **end);
/* this is used by write to estimate the number of chars necessary to
print the number */
@@ -104,7 +104,7 @@ int32_t kbigint_print_size(TValue tv_bigint, int32_t base);
/* this is used by write */
void kbigint_print_string(klisp_State *K, TValue tv_bigint, int32_t base,
- char *buf, int32_t limit);
+ char *buf, int32_t limit);
/* Interface for kgnumbers */
bool kbigint_eqp(TValue bigint1, TValue bigint2);
diff --git a/src/kkeyword.c b/src/kkeyword.c
@@ -20,34 +20,34 @@ TValue kkeyword_new_bs(klisp_State *K, const char *buf, int32_t size)
/* First calculate the hash */
uint32_t h = size; /* seed */
size_t step = (size>>5)+1; /* if string is too long, don't hash all
- its chars */
+ its chars */
size_t size1;
for (size1 = size; size1 >= step; size1 -= step) /* compute hash */
- h = h ^ ((h<<5)+(h>>2)+ ((unsigned char) buf[size1-1]));
+ h = h ^ ((h<<5)+(h>>2)+ ((unsigned char) buf[size1-1]));
h ^= (uint32_t) 0x55555555;
- /* keyword hash should be different from string & symbol hash
- otherwise keywords and their respective immutable string
- would always fall in the same bucket */
+ /* keyword hash should be different from string & symbol hash
+ otherwise keywords and their respective immutable string
+ would always fall in the same bucket */
/* look for it in the table */
for (GCObject *o = K->strt.hash[lmod(h, K->strt.size)]; o != NULL;
- o = o->gch.next) {
- klisp_assert(o->gch.tt == K_TKEYWORD || o->gch.tt == K_TSYMBOL ||
- o->gch.tt == K_TSTRING || o->gch.tt == K_TBYTEVECTOR);
-
- if (o->gch.tt != K_TKEYWORD) continue;
+ o = o->gch.next) {
+ klisp_assert(o->gch.tt == K_TKEYWORD || o->gch.tt == K_TSYMBOL ||
+ o->gch.tt == K_TSTRING || o->gch.tt == K_TBYTEVECTOR);
+
+ if (o->gch.tt != K_TKEYWORD) continue;
- String *ts = tv2str(((Keyword *) o)->str);
- if (ts->size == size && (memcmp(buf, ts->b, size) == 0)) {
- /* keyword and/or string may be dead */
- if (isdead(K, o)) changewhite(o);
- if (isdead(K, (GCObject *) ts)) changewhite((GCObject *) ts);
- return gc2keyw(o);
- }
+ String *ts = tv2str(((Keyword *) o)->str);
+ if (ts->size == size && (memcmp(buf, ts->b, size) == 0)) {
+ /* keyword and/or string may be dead */
+ if (isdead(K, o)) changewhite(o);
+ if (isdead(K, (GCObject *) ts)) changewhite((GCObject *) ts);
+ return gc2keyw(o);
+ }
}
/* REFACTOR: move this to a new function */
/* Didn't find it, alloc new immutable string and save in keyword table,
- note that the hash value remained in h */
+ note that the hash value remained in h */
TValue new_str = kstring_new_bs_imm(K, buf, size);
krooted_tvs_push(K, new_str);
Keyword *new_keyw = klispM_new(K, Keyword);
@@ -74,9 +74,9 @@ TValue kkeyword_new_bs(klisp_State *K, const char *buf, int32_t size)
tb->hash[h] = (GCObject *)(new_keyw);
tb->nuse++;
if (tb->nuse > ((uint32_t) tb->size) && tb->size <= INT32_MAX / 2) {
- krooted_tvs_push(K, ret_tv); /* save in case of gc */
- klispS_resize(K, tb->size*2); /* too crowded */
- krooted_tvs_pop(K);
+ krooted_tvs_push(K, ret_tv); /* save in case of gc */
+ klispS_resize(K, tb->size*2); /* too crowded */
+ krooted_tvs_pop(K);
}
return ret_tv;
}
diff --git a/src/klisp.c b/src/klisp.c
@@ -57,31 +57,31 @@ static const char *progname = KLISP_PROGNAME;
static void print_usage (void)
{
fprintf(stderr,
- "usage: %s [options] [script [args]].\n"
- "Available options are:\n"
- " -e exp eval string " KLISP_QL("exp") "\n"
- " -l name load file " KLISP_QL("name") "\n"
- " -r name require file " KLISP_QL("name") "\n"
- " -i enter interactive mode after executing "
- KLISP_QL("script") "\n"
- " -v show version information\n"
- " -- stop handling options\n"
- " - execute stdin and stop handling options\n"
- ,
- progname);
+ "usage: %s [options] [script [args]].\n"
+ "Available options are:\n"
+ " -e exp eval string " KLISP_QL("exp") "\n"
+ " -l name load file " KLISP_QL("name") "\n"
+ " -r name require file " KLISP_QL("name") "\n"
+ " -i enter interactive mode after executing "
+ KLISP_QL("script") "\n"
+ " -v show version information\n"
+ " -- stop handling options\n"
+ " - execute stdin and stop handling options\n"
+ ,
+ progname);
fflush(stderr);
}
static void k_message (const char *pname, const char *msg)
{
if (pname)
- fprintf(stderr, "%s: ", pname);
+ fprintf(stderr, "%s: ", pname);
fprintf(stderr, "%s\n", msg);
fflush(stderr);
}
/* TODO move this to a common place to use it from elsewhere
-(like the repl) */
+ (like the repl) */
static void show_error(klisp_State *K, TValue obj) {
/* FOR NOW used only for irritant list */
TValue port = kcdr(K->kd_error_port_key);
@@ -89,66 +89,66 @@ static void show_error(klisp_State *K, TValue obj) {
/* TEMP: obj should be an error obj */
if (ttiserror(obj)) {
- Error *err_obj = tv2error(obj);
- TValue who = err_obj->who;
- char *who_str;
- /* TEMP? */
- if (ttiscontinuation(who))
- who = tv2cont(who)->comb;
-
- if (ttisstring(who)) {
- who_str = kstring_buf(who);
+ Error *err_obj = tv2error(obj);
+ TValue who = err_obj->who;
+ char *who_str;
+ /* TEMP? */
+ if (ttiscontinuation(who))
+ who = tv2cont(who)->comb;
+
+ if (ttisstring(who)) {
+ who_str = kstring_buf(who);
#if KTRACK_NAMES
- } else if (khas_name(who)) {
- TValue name = kget_name(K, who);
- who_str = ksymbol_buf(name);
+ } else if (khas_name(who)) {
+ TValue name = kget_name(K, who);
+ who_str = ksymbol_buf(name);
#endif
- } else {
- who_str = "?";
- }
- char *msg = kstring_buf(err_obj->msg);
- fprintf(stderr, "\n*ERROR*: \n");
- fprintf(stderr, "%s: %s", who_str, msg);
-
- krooted_tvs_push(K, obj);
-
- /* Msg + irritants */
- /* TODO move to a new function */
- if (!ttisnil(err_obj->irritants)) {
- fprintf(stderr, ": ");
- kwrite_display_to_port(K, port, err_obj->irritants, false);
- }
- kwrite_newline_to_port(K, port);
+ } else {
+ who_str = "?";
+ }
+ char *msg = kstring_buf(err_obj->msg);
+ fprintf(stderr, "\n*ERROR*: \n");
+ fprintf(stderr, "%s: %s", who_str, msg);
+
+ krooted_tvs_push(K, obj);
+
+ /* Msg + irritants */
+ /* TODO move to a new function */
+ if (!ttisnil(err_obj->irritants)) {
+ fprintf(stderr, ": ");
+ kwrite_display_to_port(K, port, err_obj->irritants, false);
+ }
+ kwrite_newline_to_port(K, port);
#if KTRACK_NAMES
#if KTRACK_SI
- /* Location */
- /* TODO move to a new function */
- /* MAYBE: remove */
- if (khas_name(who) || khas_si(who)) {
- fprintf(stderr, "Location: ");
- kwrite_display_to_port(K, port, who, false);
- kwrite_newline_to_port(K, port);
- }
-
- /* Backtrace */
- /* TODO move to a new function */
- TValue tv_cont = err_obj->cont;
- fprintf(stderr, "Backtrace: \n");
- while(ttiscontinuation(tv_cont)) {
- kwrite_display_to_port(K, port, tv_cont, false);
- kwrite_newline_to_port(K, port);
- Continuation *cont = tv2cont(tv_cont);
- tv_cont = cont->parent;
- }
- /* add extra newline at the end */
- kwrite_newline_to_port(K, port);
+ /* Location */
+ /* TODO move to a new function */
+ /* MAYBE: remove */
+ if (khas_name(who) || khas_si(who)) {
+ fprintf(stderr, "Location: ");
+ kwrite_display_to_port(K, port, who, false);
+ kwrite_newline_to_port(K, port);
+ }
+
+ /* Backtrace */
+ /* TODO move to a new function */
+ TValue tv_cont = err_obj->cont;
+ fprintf(stderr, "Backtrace: \n");
+ while(ttiscontinuation(tv_cont)) {
+ kwrite_display_to_port(K, port, tv_cont, false);
+ kwrite_newline_to_port(K, port);
+ Continuation *cont = tv2cont(tv_cont);
+ tv_cont = cont->parent;
+ }
+ /* add extra newline at the end */
+ kwrite_newline_to_port(K, port);
#endif
#endif
- krooted_tvs_pop(K);
+ krooted_tvs_pop(K);
} else {
- fprintf(stderr, "\n*ERROR*: not an error object passed to "
- "error continuation");
+ fprintf(stderr, "\n*ERROR*: not an error object passed to "
+ "error continuation");
}
fflush(stderr);
}
@@ -156,9 +156,9 @@ static void show_error(klisp_State *K, TValue obj) {
static int report (klisp_State *K, int status)
{
if (status == STATUS_ERROR) {
- const char *msg = "Error!";
- k_message(progname, msg);
- show_error(K, K->next_value);
+ const char *msg = "Error!";
+ k_message(progname, msg);
+ show_error(K, K->next_value);
}
return status;
}
@@ -210,7 +210,7 @@ static int dostring (klisp_State *K, const char *s, const char *name)
/* create the guard set error flag after errors */
TValue exit_int = kmake_operative(K, do_int_mark_error,
- 1, p2tv(&errorp));
+ 1, p2tv(&errorp));
krooted_tvs_push(K, exit_int);
TValue exit_guard = kcons(K, K->error_cont, exit_int);
krooted_tvs_pop(K); /* already in guard */
@@ -225,11 +225,11 @@ static int dostring (klisp_State *K, const char *s, const char *name)
TValue env = kmake_empty_environment(K);
krooted_tvs_push(K, env);
TValue outer_cont = kmake_continuation(K, K->root_cont,
- do_pass_value, 2, entry_guards, env);
+ do_pass_value, 2, entry_guards, env);
kset_outer_cont(outer_cont);
krooted_tvs_push(K, outer_cont);
TValue inner_cont = kmake_continuation(K, outer_cont,
- do_pass_value, 2, exit_guards, env);
+ do_pass_value, 2, exit_guards, env);
kset_inner_cont(inner_cont);
krooted_tvs_pop(K); krooted_tvs_pop(K); krooted_tvs_pop(K);
@@ -240,7 +240,7 @@ static int dostring (klisp_State *K, const char *s, const char *name)
that the evaluation didn't explicitly invoke the root continuation
*/
TValue discard_cont = kmake_continuation(K, inner_cont, do_int_mark_root,
- 1, p2tv(&rootp));
+ 1, p2tv(&rootp));
krooted_tvs_pop(K); /* pop inner cont */
krooted_tvs_push(K, discard_cont);
@@ -269,7 +269,7 @@ static int dostring (klisp_State *K, const char *s, const char *name)
klispS_run(K);
int status = errorp? STATUS_ERROR :
- (rootp? STATUS_ROOT : STATUS_CONTINUE);
+ (rootp? STATUS_ROOT : STATUS_CONTINUE);
/* get the standard environment again in K->next_env */
K->next_env = env;
return report(K, status);
@@ -286,8 +286,8 @@ void do_file_eval(klisp_State *K)
TValue denv = xparams[0];
TValue ls = obj;
if (!ttisnil(ls)) {
- TValue new_cont = kmake_continuation(K, kget_cc(K), do_seq, 2, ls, denv);
- kset_cc(K, new_cont);
+ TValue new_cont = kmake_continuation(K, kget_cc(K), do_seq, 2, ls, denv);
+ kset_cc(K, new_cont);
}
kapply_cc(K, KINERT);
}
@@ -317,33 +317,33 @@ static int dofile(klisp_State *K, const char *name)
/* XXX better do this in a continuation */
if (name == NULL) {
- port = kcdr(K->kd_in_port_key);
+ port = kcdr(K->kd_in_port_key);
} else {
- FILE *file = fopen(name, "r");
- if (file == NULL) {
- TValue mode_str = kstring_new_b(K, "r");
- krooted_tvs_push(K, mode_str);
- TValue name_str = kstring_new_b(K, name);
- krooted_tvs_push(K, mode_str);
- TValue error_obj = klispE_new_simple_with_errno_irritants
- (K, "fopen", 2, name_str, mode_str);
- krooted_tvs_pop(K);
- krooted_tvs_pop(K);
- K->next_value = error_obj;
- return report(K, STATUS_ERROR);
- }
+ FILE *file = fopen(name, "r");
+ if (file == NULL) {
+ TValue mode_str = kstring_new_b(K, "r");
+ krooted_tvs_push(K, mode_str);
+ TValue name_str = kstring_new_b(K, name);
+ krooted_tvs_push(K, mode_str);
+ TValue error_obj = klispE_new_simple_with_errno_irritants
+ (K, "fopen", 2, name_str, mode_str);
+ krooted_tvs_pop(K);
+ krooted_tvs_pop(K);
+ K->next_value = error_obj;
+ return report(K, STATUS_ERROR);
+ }
- TValue name_str = kstring_new_b(K, name);
- krooted_tvs_push(K, name_str);
- port = kmake_std_fport(K, name_str, false, false, file);
- krooted_tvs_pop(K);
+ TValue name_str = kstring_new_b(K, name);
+ krooted_tvs_push(K, name_str);
+ port = kmake_std_fport(K, name_str, false, false, file);
+ krooted_tvs_pop(K);
}
krooted_tvs_push(K, port);
/* TODO this is exactly the same as in string, factor the code out */
/* create the guard set error flag after errors */
TValue exit_int = kmake_operative(K, do_int_mark_error,
- 1, p2tv(&errorp));
+ 1, p2tv(&errorp));
krooted_tvs_push(K, exit_int);
TValue exit_guard = kcons(K, K->error_cont, exit_int);
krooted_tvs_pop(K); /* already in guard */
@@ -358,11 +358,11 @@ static int dofile(klisp_State *K, const char *name)
TValue env = kmake_empty_environment(K);
krooted_tvs_push(K, env);
TValue outer_cont = kmake_continuation(K, K->root_cont,
- do_pass_value, 2, entry_guards, env);
+ do_pass_value, 2, entry_guards, env);
kset_outer_cont(outer_cont);
krooted_tvs_push(K, outer_cont);
TValue inner_cont = kmake_continuation(K, outer_cont,
- do_pass_value, 2, exit_guards, env);
+ do_pass_value, 2, exit_guards, env);
kset_inner_cont(inner_cont);
krooted_tvs_pop(K); krooted_tvs_pop(K); krooted_tvs_pop(K);
@@ -375,20 +375,20 @@ static int dofile(klisp_State *K, const char *name)
that the evaluation didn't explicitly invoke the root continuation
*/
TValue discard_cont = kmake_continuation(K, inner_cont, do_int_mark_root,
- 1, p2tv(&rootp));
+ 1, p2tv(&rootp));
krooted_tvs_pop(K); /* pop inner cont */
krooted_tvs_push(K, discard_cont);
/* XXX This should probably be an extra param to the function */
env = K->next_env; /* this is the standard env that should be used for
- evaluation */
+ evaluation */
TValue eval_cont = kmake_continuation(K, discard_cont, do_file_eval,
- 1, env);
+ 1, env);
krooted_tvs_pop(K); /* pop discard cont */
krooted_tvs_push(K, eval_cont);
TValue read_cont = kmake_continuation(K, eval_cont, do_file_read,
- 1, port);
+ 1, port);
krooted_tvs_pop(K); /* pop eval cont */
krooted_tvs_pop(K); /* pop port */
kset_cc(K, read_cont); /* this will protect all conts from gc */
@@ -397,7 +397,7 @@ static int dofile(klisp_State *K, const char *name)
klispS_run(K);
int status = errorp? STATUS_ERROR :
- (rootp? STATUS_ROOT : STATUS_CONTINUE);
+ (rootp? STATUS_ROOT : STATUS_CONTINUE);
/* get the standard environment again in K->next_env */
K->next_env = env;
@@ -426,7 +426,7 @@ static int dorfile(klisp_State *K, const char *name)
/* TODO this is exactly the same as in string, factor the code out */
/* create the guard set error flag after errors */
TValue exit_int = kmake_operative(K, do_int_mark_error,
- 1, p2tv(&errorp));
+ 1, p2tv(&errorp));
krooted_tvs_push(K, exit_int);
TValue exit_guard = kcons(K, K->error_cont, exit_int);
krooted_tvs_pop(K); /* already in guard */
@@ -441,11 +441,11 @@ static int dorfile(klisp_State *K, const char *name)
TValue env = kmake_empty_environment(K);
krooted_tvs_push(K, env);
TValue outer_cont = kmake_continuation(K, K->root_cont,
- do_pass_value, 2, entry_guards, env);
+ do_pass_value, 2, entry_guards, env);
kset_outer_cont(outer_cont);
krooted_tvs_push(K, outer_cont);
TValue inner_cont = kmake_continuation(K, outer_cont,
- do_pass_value, 2, exit_guards, env);
+ do_pass_value, 2, exit_guards, env);
kset_inner_cont(inner_cont);
krooted_tvs_pop(K); krooted_tvs_pop(K); krooted_tvs_pop(K);
@@ -458,7 +458,7 @@ static int dorfile(klisp_State *K, const char *name)
that the evaluation didn't explicitly invoke the root continuation
*/
TValue discard_cont = kmake_continuation(K, inner_cont, do_int_mark_root,
- 1, p2tv(&rootp));
+ 1, p2tv(&rootp));
krooted_tvs_pop(K); /* pop inner cont */
@@ -482,7 +482,7 @@ static int dorfile(klisp_State *K, const char *name)
klispS_run(K);
int status = errorp? STATUS_ERROR :
- (rootp? STATUS_ROOT : STATUS_CONTINUE);
+ (rootp? STATUS_ROOT : STATUS_CONTINUE);
/* get the standard environment again in K->next_env */
K->next_env = env;
@@ -497,7 +497,7 @@ static int handle_script(klisp_State *K, char **argv, int n)
// lua_setglobal(L, "arg");
fname = argv[n];
if (strcmp(fname, "-") == 0 && strcmp(argv[n-1], "--") != 0)
- fname = NULL; /* stdin */
+ fname = NULL; /* stdin */
return dofile(K, fname);
}
@@ -509,38 +509,38 @@ static int collectargs (char **argv, bool *pi, bool *pv, bool *pe, bool *pl)
{
int i;
for (i = 1; argv[i] != NULL; i++) {
- if (argv[i][0] != '-') /* not an option? */
- return i;
- switch (argv[i][1]) { /* option */
- case '-':
- notail(argv[i]);
- return (argv[i+1] != NULL ? i+1 : 0);
- case '\0':
- return i;
- case 'i':
- notail(argv[i]);
- *pi = true; /* go through */
- case 'v':
- notail(argv[i]);
- *pv = true;
- break;
- case 'e':
- *pe = true;
- goto select_arg;
- case 'l':
- *pl = true;
- goto select_arg;
- case 'r':
- select_arg:
- if (argv[i][2] == '\0') {
- i++;
- if (argv[i] == NULL)
- return -1;
- }
- break;
- default:
- return -1; /* invalid option */
- }
+ if (argv[i][0] != '-') /* not an option? */
+ return i;
+ switch (argv[i][1]) { /* option */
+ case '-':
+ notail(argv[i]);
+ return (argv[i+1] != NULL ? i+1 : 0);
+ case '\0':
+ return i;
+ case 'i':
+ notail(argv[i]);
+ *pi = true; /* go through */
+ case 'v':
+ notail(argv[i]);
+ *pv = true;
+ break;
+ case 'e':
+ *pe = true;
+ goto select_arg;
+ case 'l':
+ *pl = true;
+ goto select_arg;
+ case 'r':
+ select_arg:
+ if (argv[i][2] == '\0') {
+ i++;
+ if (argv[i] == NULL)
+ return -1;
+ }
+ break;
+ default:
+ return -1; /* invalid option */
+ }
}
return 0;
}
@@ -553,54 +553,54 @@ static int runargs (klisp_State *K, char **argv, int n)
UNUSED(env);
/* TEMP All passes to root cont and all resulting values will be ignored,
- the only way to interrupt the running of arguments is to throw an error */
+ the only way to interrupt the running of arguments is to throw an error */
for (int i = 1; i < n; i++) {
- if (argv[i] == NULL)
- continue;
-
- klisp_assert(argv[i][0] == '-');
-
- switch (argv[i][1]) { /* option */
- case 'e': { /* eval expr */
- const char *chunk = argv[i] + 2;
- if (*chunk == '\0')
- chunk = argv[++i];
- klisp_assert(chunk != NULL);
-
- int res = dostring(K, chunk, "=(command line)");
- if (res != STATUS_CONTINUE)
- return res; /* stop if eval fails/exit */
- break;
- }
- case 'l': { /* load file */
- const char *filename = argv[i] + 2;
- if (*filename == '\0') filename = argv[++i];
- klisp_assert(filename != NULL);
+ if (argv[i] == NULL)
+ continue;
+
+ klisp_assert(argv[i][0] == '-');
+
+ switch (argv[i][1]) { /* option */
+ case 'e': { /* eval expr */
+ const char *chunk = argv[i] + 2;
+ if (*chunk == '\0')
+ chunk = argv[++i];
+ klisp_assert(chunk != NULL);
+
+ int res = dostring(K, chunk, "=(command line)");
+ if (res != STATUS_CONTINUE)
+ return res; /* stop if eval fails/exit */
+ break;
+ }
+ case 'l': { /* load file */
+ const char *filename = argv[i] + 2;
+ if (*filename == '\0') filename = argv[++i];
+ klisp_assert(filename != NULL);
- int res = dofile(K, filename);
- if (res != STATUS_CONTINUE)
- return res; /* stop if file fails/exit */
- break;
- }
- case 'r': { /* require file */
- const char *filename = argv[i] + 2;
- if (*filename == '\0') filename = argv[++i];
- klisp_assert(filename != NULL);
+ int res = dofile(K, filename);
+ if (res != STATUS_CONTINUE)
+ return res; /* stop if file fails/exit */
+ break;
+ }
+ case 'r': { /* require file */
+ const char *filename = argv[i] + 2;
+ if (*filename == '\0') filename = argv[++i];
+ klisp_assert(filename != NULL);
- int res = dorfile(K, filename);
- if (res != STATUS_CONTINUE)
- return res; /* stop if file fails/exit */
- break;
- }
- default:
- break;
- }
+ int res = dorfile(K, filename);
+ if (res != STATUS_CONTINUE)
+ return res; /* stop if file fails/exit */
+ break;
+ }
+ default:
+ break;
+ }
}
return STATUS_CONTINUE;
}
static void populate_argument_lists(klisp_State *K, char **argv, int argc,
- int script)
+ int script)
{
/* first create the script list */
TValue tail = KNIL;
@@ -608,9 +608,9 @@ static void populate_argument_lists(klisp_State *K, char **argv, int argc,
krooted_vars_push(K, &tail);
krooted_vars_push(K, &obj);
while(argc > script) {
- char *arg = argv[--argc];
- obj = kstring_new_b_imm(K, arg);
- tail = kimm_cons(K, obj, tail);
+ char *arg = argv[--argc];
+ obj = kstring_new_b_imm(K, arg);
+ tail = kimm_cons(K, obj, tail);
}
/* Store the script argument list */
obj = ksymbol_new_b(K, "get-script-arguments", KNIL);
@@ -619,9 +619,9 @@ static void populate_argument_lists(klisp_State *K, char **argv, int argc,
tv2op(obj)->extra[0] = tail;
while(argc > 0) {
- char *arg = argv[--argc];
- obj = kstring_new_b_imm(K, arg);
- tail = kimm_cons(K, obj, tail);
+ char *arg = argv[--argc];
+ obj = kstring_new_b_imm(K, arg);
+ tail = kimm_cons(K, obj, tail);
}
/* Store the interpreter argument list */
obj = ksymbol_new_b(K, "get-interpreter-arguments", KNIL);
@@ -638,9 +638,9 @@ static int handle_klispinit(klisp_State *K)
const char *init = getenv(KLISP_INIT);
int res;
if (init == NULL)
- res = STATUS_CONTINUE;
+ res = STATUS_CONTINUE;
else
- res = dostring(K, init, "=" KLISP_INIT);
+ res = dostring(K, init, "=" KLISP_INIT);
return res;
}
@@ -667,7 +667,7 @@ static void pmain(klisp_State *K)
//TValue env = K->next_env;
if (argv[0] && argv[0][0])
- progname = argv[0];
+ progname = argv[0];
/* TODO Here we should load libraries, however we don't have any
non native bindings in the ground environment yet */
@@ -680,19 +680,19 @@ static void pmain(klisp_State *K)
/* init (eval KLISP_INIT env variable contents) */
s->status = handle_klispinit(K);
if (s->status != STATUS_CONTINUE)
- return;
+ return;
bool has_i = false, has_v = false, has_e = false, has_l = false;
int script = collectargs(argv, &has_i, &has_v, &has_e, &has_l);
if (script < 0) { /* invalid args? */
- print_usage();
- s->status = STATUS_ERROR;
- return;
+ print_usage();
+ s->status = STATUS_ERROR;
+ return;
}
if (has_v)
- print_version();
+ print_version();
/* TEMP this could be either set before or after running the arguments,
we'll do it before for now */
@@ -701,24 +701,24 @@ static void pmain(klisp_State *K)
s->status = runargs(K, argv, (script > 0) ? script : s->argc);
if (s->status != STATUS_CONTINUE)
- return;
+ return;
if (script > 0) {
- s->status = handle_script(K, argv, script);
+ s->status = handle_script(K, argv, script);
}
if (s->status != STATUS_CONTINUE)
- return;
+ return;
if (has_i) {
- dotty(K);
+ dotty(K);
} else if (script == 0 && !has_e && !has_l && !has_v) {
- if (ksystem_isatty(K, kcurr_input_port(K))) {
- print_version();
- dotty(K);
- } else {
- s->status = dofile(K, NULL);
- }
+ if (ksystem_isatty(K, kcurr_input_port(K))) {
+ print_version();
+ dotty(K);
+ } else {
+ s->status = dofile(K, NULL);
+ }
}
}
@@ -728,8 +728,8 @@ int main(int argc, char *argv[])
klisp_State *K = klispL_newstate();
if (K == NULL) {
- k_message(argv[0], "cannot create state: not enough memory");
- return EXIT_FAILURE;
+ k_message(argv[0], "cannot create state: not enough memory");
+ return EXIT_FAILURE;
}
/* This is weird but was done to follow lua scheme */
@@ -741,19 +741,19 @@ int main(int argc, char *argv[])
/* convert s.status to either EXIT_SUCCESS or EXIT_FAILURE */
if (s.status == STATUS_CONTINUE || s.status == STATUS_ROOT) {
- /* must check value passed to the root continuation to
- return proper exit status */
- if (ttisinert(K->next_value)) {
- s.status = EXIT_SUCCESS;
- } else if (ttisboolean(K->next_value)) {
- s.status = kis_true(K->next_value)? EXIT_SUCCESS : EXIT_FAILURE;
- } else if (ttisfixint(K->next_value)) {
- s.status = ivalue(K->next_value);
- } else {
- s.status = EXIT_FAILURE;
- }
+ /* must check value passed to the root continuation to
+ return proper exit status */
+ if (ttisinert(K->next_value)) {
+ s.status = EXIT_SUCCESS;
+ } else if (ttisboolean(K->next_value)) {
+ s.status = kis_true(K->next_value)? EXIT_SUCCESS : EXIT_FAILURE;
+ } else if (ttisfixint(K->next_value)) {
+ s.status = ivalue(K->next_value);
+ } else {
+ s.status = EXIT_FAILURE;
+ }
} else { /* s.status == STATUS_ERROR */
- s.status = EXIT_FAILURE;
+ s.status = EXIT_FAILURE;
}
klisp_close(K);
diff --git a/src/klisp.h b/src/klisp.h
@@ -44,29 +44,29 @@ klisp_State *klisp_newstate (klisp_Alloc f, void *ud);
void klisp_close (klisp_State *K);
/******************************************************************************
-* Copyright (C) 2011 Andres Navarro, Oto Havle.
-* Lua parts: Copyright (C) 1994-2010 Lua.org, PUC-Rio.
-* IMath Parts: Copyright (C) 2002-2007 Michael J. Fromberger.
-* srfi-78: Copyright (C) 2005-2006 Sebastian Egner.
-*
-* Permission is hereby granted, free of charge, to any person obtaining
-* a copy of this software and associated documentation files (the
-* "Software"), to deal in the Software without restriction, including
-* without limitation the rights to use, copy, modify, merge, publish,
-* distribute, sublicense, and/or sell copies of the Software, and to
-* permit persons to whom the Software is furnished to do so, subject to
-* the following conditions:
-*
-* The above copyright notice and this permission notice shall be
-* included in all copies or substantial portions of the Software.
-*
-* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
-* EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
-* MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
-* IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
-* CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
-* TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
-* SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
-******************************************************************************/
+ * Copyright (C) 2011 Andres Navarro, Oto Havle.
+ * Lua parts: Copyright (C) 1994-2010 Lua.org, PUC-Rio.
+ * IMath Parts: Copyright (C) 2002-2007 Michael J. Fromberger.
+ * srfi-78: Copyright (C) 2005-2006 Sebastian Egner.
+ *
+ * Permission is hereby granted, free of charge, to any person obtaining
+ * a copy of this software and associated documentation files (the
+ * "Software"), to deal in the Software without restriction, including
+ * without limitation the rights to use, copy, modify, merge, publish,
+ * distribute, sublicense, and/or sell copies of the Software, and to
+ * permit persons to whom the Software is furnished to do so, subject to
+ * the following conditions:
+ *
+ * The above copyright notice and this permission notice shall be
+ * included in all copies or substantial portions of the Software.
+ *
+ * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+ * EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+ * MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
+ * IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
+ * CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
+ * TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
+ * SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+ ******************************************************************************/
#endif
diff --git a/src/klispconf.h b/src/klispconf.h
@@ -20,10 +20,10 @@
*/
/*
-@@ KLISP_ANSI controls the use of non-ansi features.
-** CHANGE it (define it) if you want Klisp to avoid the use of any
-** non-ansi feature or library.
-*/
+ @@ KLISP_ANSI controls the use of non-ansi features.
+ ** CHANGE it (define it) if you want Klisp to avoid the use of any
+ ** non-ansi feature or library.
+ */
#if defined(__STRICT_ANSI__)
/* XXX currently unused */
#define KLISP_ANSI
@@ -48,24 +48,24 @@
#endif
/*
-@@ KLISP_PROGNAME is the default name for the stand-alone klisp program.
-** CHANGE it if your stand-alone interpreter has a different name and
-** your system is not able to detect that name automatically.
-*/
+ @@ KLISP_PROGNAME is the default name for the stand-alone klisp program.
+ ** CHANGE it if your stand-alone interpreter has a different name and
+ ** your system is not able to detect that name automatically.
+ */
#define KLISP_PROGNAME "klisp"
/*
-@@ KLISP_QL describes how error messages quote program elements.
-** CHANGE it if you want a different appearance.
-*/
+ @@ KLISP_QL describes how error messages quote program elements.
+ ** CHANGE it if you want a different appearance.
+ */
#define KLISP_QL(x) "'" x "'"
#define KLISP_QS KLISP_QL("%s")
/*
-@@ KLISP_USE_POSIX includes all functionallity listed as X/Open System
-@* Interfaces Extension (XSI).
-** CHANGE it (define it) if your system is XSI compatible.
-*/
+ @@ KLISP_USE_POSIX includes all functionallity listed as X/Open System
+ @* Interfaces Extension (XSI).
+ ** CHANGE it (define it) if your system is XSI compatible.
+ */
#if defined(KLISP_USE_POSIX)
#define KLISP_USE_MKSTEMP
#define KLISP_USE_ISATTY
@@ -74,26 +74,26 @@
#endif
/*
-@@ KLISP_PATH and KLISP_CPATH are the names of the environment variables that
-@* Klisp check to set its paths.
-@@ KLISP_INIT is the name of the environment variable that Klisp
-@* checks for initialization code.
-** CHANGE them if you want different names.
-*/
-#define KLISP_PATH "KLISP_PATH"
-#define KLISP_CPATH "KLISP_CPATH"
+ @@ KLISP_PATH and KLISP_CPATH are the names of the environment variables that
+ @* Klisp check to set its paths.
+ @@ KLISP_INIT is the name of the environment variable that Klisp
+ @* checks for initialization code.
+ ** CHANGE them if you want different names.
+ */
+#define KLISP_PATH "KLISP_PATH"
+#define KLISP_CPATH "KLISP_CPATH"
#define KLISP_INIT "KLISP_INIT"
/*
-@@ KLISP_PATH_DEFAULT is the default path that Klisp uses to look for
-@* Klisp libraries.
-@@ KLISP_CPATH_DEFAULT is the default path that Klisp uses to look for
-@* C libraries.
-** CHANGE them if your machine has a non-conventional directory
-** hierarchy or if you want to install your libraries in
-** non-conventional directories.
-*/
+ @@ KLISP_PATH_DEFAULT is the default path that Klisp uses to look for
+ @* Klisp libraries.
+ @@ KLISP_CPATH_DEFAULT is the default path that Klisp uses to look for
+ @* C libraries.
+ ** CHANGE them if your machine has a non-conventional directory
+ ** hierarchy or if you want to install your libraries in
+ ** non-conventional directories.
+ */
#if defined(_WIN32)
/*
** In Windows, any exclamation mark ('!') in the path is replaced by the
@@ -103,10 +103,10 @@
#define KLISP_CDIR "!\\"
#define KLISP_PATH_DEFAULT \
".\\?.k;" ".\\?" \
- KLISP_LDIR"?.k;" KLISP_LDIR"?;" \
+ KLISP_LDIR"?.k;" KLISP_LDIR"?;" \
KLISP_CDIR"?.k;" KLISP_CDIR"?;"
/* XXX Not used for now */
-#define KLISP_CPATH_DEFAULT \
+#define KLISP_CPATH_DEFAULT \
".\\?.dll;" KLISP_CDIR"?.dll;" KLISP_CDIR"loadall.dll"
#else
@@ -115,21 +115,21 @@
#define KLISP_CDIR KLISP_ROOT "lib/klisp/0.3/"
#define KLISP_PATH_DEFAULT \
"./?.k;./?;" \
- KLISP_LDIR"?.k;" KLISP_LDIR"?;" \
+ KLISP_LDIR"?.k;" KLISP_LDIR"?;" \
KLISP_CDIR"?;" KLISP_CDIR"?.k"
/* XXX Not used for now */
-#define KLISP_CPATH_DEFAULT \
+#define KLISP_CPATH_DEFAULT \
"./?.so;" KLISP_CDIR"?.so;" KLISP_CDIR"loadall.so"
#endif
/*
-@@ KLISP_DIRSEP is the directory separator (for submodules).
-** XXX KLISP_DIRSEP is not currently used
-** This allows naturally looking paths in windows while still using
-** CHANGE it if your machine does not use "/" as the directory separator
-** and is not Windows. (On Windows Klisp automatically uses "\".)
-*/
+ @@ KLISP_DIRSEP is the directory separator (for submodules).
+ ** XXX KLISP_DIRSEP is not currently used
+ ** This allows naturally looking paths in windows while still using
+ ** CHANGE it if your machine does not use "/" as the directory separator
+ ** and is not Windows. (On Windows Klisp automatically uses "\".)
+ */
#if defined(_WIN32)
#define KLISP_DIRSEP "\\"
#else
@@ -138,29 +138,29 @@
/*
-@@ KLISP_PATHSEP is the character that separates templates in a path.
-@@ KLISP_PATH_MARK is the string that marks the substitution points in a
-@* template.
-@@ KLISP_EXECDIR in a Windows path is replaced by the executable's
-@* directory.
-@@ XXX KLISP_IGMARK is not currently used in klisp.
-@@ KLISP_IGMARK is a mark to ignore all before it when bulding the
-@* klispopen_ function name.
-** CHANGE them if for some reason your system cannot use those
-** characters. (E.g., if one of those characters is a common character
-** in file/directory names.) Probably you do not need to change them.
-*/
+ @@ KLISP_PATHSEP is the character that separates templates in a path.
+ @@ KLISP_PATH_MARK is the string that marks the substitution points in a
+ @* template.
+ @@ KLISP_EXECDIR in a Windows path is replaced by the executable's
+ @* directory.
+ @@ XXX KLISP_IGMARK is not currently used in klisp.
+ @@ KLISP_IGMARK is a mark to ignore all before it when bulding the
+ @* klispopen_ function name.
+ ** CHANGE them if for some reason your system cannot use those
+ ** characters. (E.g., if one of those characters is a common character
+ ** in file/directory names.) Probably you do not need to change them.
+ */
#define KLISP_PATHSEP ";"
#define KLISP_PATH_MARK "?"
#define KLISP_EXECDIR "!"
#define KLISP_IGMARK "-"
/*
-@@ klisp_stdin_is_tty detects whether the standard input is a 'tty' (that
-@* is, whether we're running klisp interactively).
-** CHANGE it if you have a better definition for non-POSIX/non-Windows
-** systems.
-*/
+ @@ klisp_stdin_is_tty detects whether the standard input is a 'tty' (that
+ @* is, whether we're running klisp interactively).
+ ** CHANGE it if you have a better definition for non-POSIX/non-Windows
+ ** systems.
+ */
#if defined(KLISP_USE_ISATTY)
#include <unistd.h>
#define klisp_stdin_is_tty() isatty(0)
@@ -173,10 +173,10 @@
#endif
/*
-@@ KLISP_PROMPT is the default prompt used by stand-alone Klisp.
-@@ KLISP_PROMPT2 is not currently used.
-** CHANGE them if you want different prompts.
-*/
+ @@ KLISP_PROMPT is the default prompt used by stand-alone Klisp.
+ @@ KLISP_PROMPT2 is not currently used.
+ ** CHANGE them if you want different prompts.
+ */
#define KLISP_PROMPT "klisp> "
/* XXX not used for now */
#define KLISP_PROMPT2 ">> "
@@ -187,7 +187,7 @@
/* #define KDEBUG_GC 1 */
/*
-#define KTRACK_MARKS true
+ #define KTRACK_MARKS true
*/
/* TODO use this defines everywhere */
@@ -200,12 +200,12 @@
manually adjusted after every collection to override the intenal
calculation done with KLISPI_GCPAUSE */
/*
-@@ KLISPI_GCPAUSE defines the default pause between garbage-collector cycles
-@* as a percentage.
-** CHANGE it if you want the GC to run faster or slower (higher values
-** mean larger pauses which mean slower collection.) You can also change
-** this value dynamically.
-*/
+ @@ KLISPI_GCPAUSE defines the default pause between garbage-collector cycles
+ @* as a percentage.
+ ** CHANGE it if you want the GC to run faster or slower (higher values
+ ** mean larger pauses which mean slower collection.) You can also change
+ ** this value dynamically.
+ */
/* In lua that has incremental gc this is setted to 200, in
klisp as we don't yet have incremental gc, we set it to 400 */
@@ -213,23 +213,23 @@
/*
-@@ KLISPI_GCMUL defines the default speed of garbage collection relative to
-@* memory allocation as a percentage.
-** CHANGE it if you want to change the granularity of the garbage
-** collection. (Higher values mean coarser collections. 0 represents
-** infinity, where each step performs a full collection.) You can also
-** change this value dynamically.
-*/
+ @@ KLISPI_GCMUL defines the default speed of garbage collection relative to
+ @* memory allocation as a percentage.
+ ** CHANGE it if you want to change the granularity of the garbage
+ ** collection. (Higher values mean coarser collections. 0 represents
+ ** infinity, where each step performs a full collection.) You can also
+ ** change this value dynamically.
+ */
#define KLISPI_GCMUL 200 /* GC runs 'twice the speed' of memory allocation */
/*
-@@ KLISP_API is a mark for all core API functions.
-@@ KLISPLIB_API is a mark for all standard library functions.
-** CHANGE them if you need to define those functions in some special way.
-** For instance, if you want to create one Windows DLL with the core and
-** the libraries, you may want to use the following definition (define
-** KLISP_BUILD_AS_DLL to get it).
-*/
+ @@ KLISP_API is a mark for all core API functions.
+ @@ KLISPLIB_API is a mark for all standard library functions.
+ ** CHANGE them if you need to define those functions in some special way.
+ ** For instance, if you want to create one Windows DLL with the core and
+ ** the libraries, you may want to use the following definition (define
+ ** KLISP_BUILD_AS_DLL to get it).
+ */
#if defined(KLISP_BUILD_AS_DLL)
#if defined(KLISP_CORE) || defined(KLISP_LIB)
diff --git a/src/kmem.c b/src/kmem.c
@@ -41,18 +41,18 @@
*/
void *klispM_growaux_ (klisp_State *K, void *block, int *size, size_t size_elems,
- int32_t limit, const char *errormsg) {
+ int32_t limit, const char *errormsg) {
void *newblock;
int32_t newsize;
if (*size >= limit/2) { /* cannot double it? */
- if (*size >= limit) /* cannot grow even a little? */
- klispE_throw_simple(K, (char *) errormsg); /* XXX */
- newsize = limit; /* still have at least one free place */
+ if (*size >= limit) /* cannot grow even a little? */
+ klispE_throw_simple(K, (char *) errormsg); /* XXX */
+ newsize = limit; /* still have at least one free place */
}
else {
- newsize = (*size)*2;
- if (newsize < MINSIZEARRAY)
- newsize = MINSIZEARRAY; /* minimum size */
+ newsize = (*size)*2;
+ if (newsize < MINSIZEARRAY)
+ newsize = MINSIZEARRAY; /* minimum size */
}
newblock = klispM_reallocv(K, block, *size, newsize, size_elems);
*size = newsize; /* update only when everything else is OK */
@@ -62,8 +62,8 @@ void *klispM_growaux_ (klisp_State *K, void *block, int *size, size_t size_elems
void *klispM_toobig (klisp_State *K) {
/* TODO better msg */
- klispE_throw_simple(K, "(mem) block too big");
- return NULL; /* to avoid warnings */
+ klispE_throw_simple(K, "(mem) block too big");
+ return NULL; /* to avoid warnings */
}
@@ -71,31 +71,31 @@ void *klispM_toobig (klisp_State *K) {
** generic allocation routine.
*/
void *klispM_realloc_ (klisp_State *K, void *block, size_t osize, size_t nsize) {
- klisp_assert((osize == 0) == (block == NULL));
+ klisp_assert((osize == 0) == (block == NULL));
- /* TEMP: for now only Stop the world GC */
- /* TEMP: prevent recursive call of klispC_fullgc() */
- #ifdef KUSE_GC
- if (nsize > 0 && K->totalbytes - osize + nsize >= K->GCthreshold) {
- #ifdef KDEBUG_GC
- printf("GC START, total_bytes: %d\n", K->totalbytes);
- #endif
- klispC_fullgc(K);
- #ifdef KDEBUG_GC
- printf("GC END, total_bytes: %d\n", K->totalbytes);
- #endif
- }
- #endif
+ /* TEMP: for now only Stop the world GC */
+ /* TEMP: prevent recursive call of klispC_fullgc() */
+#ifdef KUSE_GC
+ if (nsize > 0 && K->totalbytes - osize + nsize >= K->GCthreshold) {
+#ifdef KDEBUG_GC
+ printf("GC START, total_bytes: %d\n", K->totalbytes);
+#endif
+ klispC_fullgc(K);
+#ifdef KDEBUG_GC
+ printf("GC END, total_bytes: %d\n", K->totalbytes);
+#endif
+ }
+#endif
- block = (*K->frealloc)(K->ud, block, osize, nsize);
+ block = (*K->frealloc)(K->ud, block, osize, nsize);
- if (block == NULL && nsize > 0) {
- /* TEMP: try GC if there is no more mem */
- /* TODO: make this a catchable error */
- fprintf(stderr, MEMERRMSG);
- abort();
- }
- klisp_assert((nsize == 0) == (block == NULL));
- K->totalbytes = (K->totalbytes - osize) + nsize;
- return block;
+ if (block == NULL && nsize > 0) {
+ /* TEMP: try GC if there is no more mem */
+ /* TODO: make this a catchable error */
+ fprintf(stderr, MEMERRMSG);
+ abort();
+ }
+ klisp_assert((nsize == 0) == (block == NULL));
+ K->totalbytes = (K->totalbytes - osize) + nsize;
+ return block;
}
diff --git a/src/kmem.h b/src/kmem.h
@@ -17,9 +17,9 @@
#define MEMERRMSG "not enough memory"
-#define klispM_reallocv(L,b,on,n,e) \
+#define klispM_reallocv(L,b,on,n,e) \
((cast(size_t, (n)+1) <= SIZE_MAX/(e)) ? /* +1 to avoid warnings */ \
- klispM_realloc_(L, (b), (on)*(e), (n)*(e)) : \
+ klispM_realloc_(L, (b), (on)*(e), (n)*(e)) : \
klispM_toobig(L))
#define klispM_freemem(K, b, s) klispM_realloc_(K, (b), (s), 0)
@@ -28,21 +28,21 @@
#define klispM_malloc(K,t) klispM_realloc_(K, NULL, 0, (t))
#define klispM_new(K,t) cast(t *, klispM_malloc(K, sizeof(t)))
-#define klispM_newvector(L,n,t) \
- cast(t *, klispM_reallocv(L, NULL, 0, n, sizeof(t)))
+#define klispM_newvector(L,n,t) \
+ cast(t *, klispM_reallocv(L, NULL, 0, n, sizeof(t)))
-#define klispM_growvector(L,v,nelems,size,t,limit,e) \
- if ((nelems)+1 > (size)) \
- ((v)=cast(t *, klispM_growaux_(L,v,&(size),sizeof(t),limit,e)))
+#define klispM_growvector(L,v,nelems,size,t,limit,e) \
+ if ((nelems)+1 > (size)) \
+ ((v)=cast(t *, klispM_growaux_(L,v,&(size),sizeof(t),limit,e)))
-#define klispM_reallocvector(L, v,oldn,n,t) \
+#define klispM_reallocvector(L, v,oldn,n,t) \
((v)=cast(t *, klispM_reallocv(L, v, oldn, n, sizeof(t))))
void *klispM_realloc_ (klisp_State *K, void *block, size_t oldsize,
- size_t size);
+ size_t size);
void *klispM_toobig (klisp_State *K);
void *klispM_growaux_ (klisp_State *K, void *block, int *size,
- size_t size_elem, int limit,
- const char *errormsg);
+ size_t size_elem, int limit,
+ const char *errormsg);
#endif
diff --git a/src/kmodule.c b/src/kmodule.c
@@ -19,7 +19,7 @@ TValue kmake_module(klisp_State *K, TValue env, TValue exp_list)
/* header + gc_fields */
klispC_link(K, (GCObject *) new_mod, K_TMODULE,
- K_FLAG_CAN_HAVE_NAME);
+ K_FLAG_CAN_HAVE_NAME);
/* module specific fields */
new_mod->env = env;
diff --git a/src/kobject.c b/src/kobject.c
@@ -57,7 +57,7 @@ char *ktv_names[] = {
[K_TCOMPLEX] = "complex",
[K_TUNDEFINED] = "undefined",
- [K_TNIL] = "nil",
+ [K_TNIL] = "nil",
[K_TIGNORE] = "ignore",
[K_TINERT] = "inert",
[K_TEOF] = "eof",
@@ -87,17 +87,17 @@ char *ktv_names[] = {
};
int32_t klispO_log2 (uint32_t x) {
- static const uint8_t log_2[256] = {
- 0,1,2,2,3,3,3,3,4,4,4,4,4,4,4,4,5,5,5,5,5,5,5,5,5,5,5,5,5,5,5,5,
- 6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,
- 7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,
- 7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,
- 8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,
- 8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,
- 8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,
- 8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8
- };
- int32_t l = -1;
- while (x >= 256) { l += 8; x >>= 8; }
- return l + log_2[x];
+ static const uint8_t log_2[256] = {
+ 0,1,2,2,3,3,3,3,4,4,4,4,4,4,4,4,5,5,5,5,5,5,5,5,5,5,5,5,5,5,5,5,
+ 6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,
+ 7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,
+ 7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,
+ 8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,
+ 8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,
+ 8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,
+ 8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8
+ };
+ int32_t l = -1;
+ while (x >= 256) { l += 8; x >>= 8; }
+ return l + log_2[x];
}
diff --git a/src/kobject.h b/src/kobject.h
@@ -45,7 +45,7 @@ typedef union GCObject GCObject;
** Common Header for all collectible objects (in macro form, to be
** included in other objects)
*/
-#define CommonHeader GCObject *next; uint8_t tt; uint8_t kflags; \
+#define CommonHeader GCObject *next; uint8_t tt; uint8_t kflags; \
uint16_t gct; GCObject *si; GCObject *gclist
/* NOTE: the gc flags are called marked in lua, but we reserve that them
@@ -78,7 +78,7 @@ typedef union GCObject GCObject;
** Common header in struct form
*/
typedef struct __attribute__ ((__packed__)) GCheader {
- CommonHeader;
+ CommonHeader;
} GCheader;
/*
@@ -131,16 +131,16 @@ typedef struct __attribute__ ((__packed__)) GCheader {
** The name strings for all TValue types are in kobject.c
** Thoseshould be updated if types here are modified
*/
-#define K_TFIXINT 0
-#define K_TBIGINT 1
-#define K_TFIXRAT 2
-#define K_TBIGRAT 3
-#define K_TDOUBLE 4
-#define K_TBDOUBLE 5
-#define K_TEINF 6
-#define K_TIINF 7
-#define K_TRWNPV 8
-#define K_TCOMPLEX 9
+#define K_TFIXINT 0
+#define K_TBIGINT 1
+#define K_TFIXRAT 2
+#define K_TBIGRAT 3
+#define K_TDOUBLE 4
+#define K_TBDOUBLE 5
+#define K_TEINF 6
+#define K_TIINF 7
+#define K_TRWNPV 8
+#define K_TCOMPLEX 9
#define K_TUNDEFINED 10
#define K_TNIL 20
@@ -153,7 +153,7 @@ typedef struct __attribute__ ((__packed__)) GCheader {
/* user pointer */
#define K_TUSER 29
-#define K_TPAIR 30
+#define K_TPAIR 30
#define K_TSTRING 31
#define K_TSYMBOL 32
#define K_TENVIRONMENT 33
@@ -161,18 +161,18 @@ typedef struct __attribute__ ((__packed__)) GCheader {
#define K_TOPERATIVE 35
#define K_TAPPLICATIVE 36
#define K_TENCAPSULATION 37
-#define K_TPROMISE 38
-#define K_TTABLE 39
-#define K_TERROR 40
+#define K_TPROMISE 38
+#define K_TTABLE 39
+#define K_TERROR 40
#define K_TBYTEVECTOR 41
-#define K_TFPORT 42
-#define K_TMPORT 43
-#define K_TVECTOR 44
+#define K_TFPORT 42
+#define K_TMPORT 43
+#define K_TVECTOR 44
#define K_TKEYWORD 45
#define K_TMODULE 46
/* for tables */
-#define K_TDEADKEY 60
+#define K_TDEADKEY 60
/* this is used to test for numbers, as returned by ttype */
#define K_LAST_NUMBER_TYPE K_TUNDEFINED
@@ -233,8 +233,8 @@ typedef struct __attribute__ ((__packed__)) GCheader {
*/
/* NOTE: This is intended for use in switch statements */
-#define ttype(o) ({ TValue tto_ = (o); \
- ttisdouble(tto_)? K_TDOUBLE : ttype_(tto_); })
+#define ttype(o) ({ TValue tto_ = (o); \
+ ttisdouble(tto_)? K_TDOUBLE : ttype_(tto_); })
/* This is intended for internal use below. DON'T USE OUTSIDE THIS FILE */
#define ttag(o) ((o).tv.t)
@@ -246,51 +246,51 @@ typedef struct __attribute__ ((__packed__)) GCheader {
/* Simple types (value in TValue struct) */
#define ttisfixint(o) (tbasetype_(o) == K_TAG_FIXINT)
#define ttisbigint(o) (tbasetype_(o) == K_TAG_BIGINT)
-#define ttiseinteger(o_) ({ int32_t t_ = tbasetype_(o_); \
- t_ == K_TAG_FIXINT || t_ == K_TAG_BIGINT;})
+#define ttiseinteger(o_) ({ int32_t t_ = tbasetype_(o_); \
+ t_ == K_TAG_FIXINT || t_ == K_TAG_BIGINT;})
/* for items in bytevectors */
-#define ttisu8(o) ({ \
- TValue o__ = (o); \
- (ttisfixint(o__) && ivalue(o__) >= 0 && ivalue(o__) < 256); })
+#define ttisu8(o) ({ \
+ TValue o__ = (o); \
+ (ttisfixint(o__) && ivalue(o__) >= 0 && ivalue(o__) < 256); })
/* for radixes in string<->number */
-#define ttisradix(o) ({ \
- TValue o__ = (o); \
- (ttisfixint(o__) && \
- (ivalue(o__) == 2 || ivalue(o__) == 8 || \
- ivalue(o__) == 10 || ivalue(o__) == 16)); })
+#define ttisradix(o) ({ \
+ TValue o__ = (o); \
+ (ttisfixint(o__) && \
+ (ivalue(o__) == 2 || ivalue(o__) == 8 || \
+ ivalue(o__) == 10 || ivalue(o__) == 16)); })
/* for bases in char->digit and related functions */
-#define ttisbase(o) ({ \
- TValue o__ = (o); \
- (ttisfixint(o__) && ivalue(o__) >= 2 && ivalue(o__) <= 36); })
-#define ttisinteger(o) ({ TValue o__ = (o); \
- (ttiseinteger(o__) || \
- (ttisdouble(o__) && (floor(dvalue(o__)) == dvalue(o__))));})
+#define ttisbase(o) ({ \
+ TValue o__ = (o); \
+ (ttisfixint(o__) && ivalue(o__) >= 2 && ivalue(o__) <= 36); })
+#define ttisinteger(o) ({ TValue o__ = (o); \
+ (ttiseinteger(o__) || \
+ (ttisdouble(o__) && (floor(dvalue(o__)) == dvalue(o__))));})
#define ttisbigrat(o) (tbasetype_(o) == K_TAG_BIGRAT)
-#define ttisrational(o_) \
- ({ TValue t_ = o_; \
- (ttype(t_) <= K_TBIGRAT) || ttisdouble(t_); })
+#define ttisrational(o_) \
+ ({ TValue t_ = o_; \
+ (ttype(t_) <= K_TBIGRAT) || ttisdouble(t_); })
#define ttisdouble(o) ((ttag(o) & K_TAG_BASE_MASK) != K_TAG_TAGGED)
#define ttisreal(o) (ttype(o) < K_TCOMPLEX)
-#define ttisexact(o_) \
- ({ TValue t_ = o_; \
- (ttiseinf(t_) || ttype(t_) <= K_TBIGRAT); })
+#define ttisexact(o_) \
+ ({ TValue t_ = o_; \
+ (ttiseinf(t_) || ttype(t_) <= K_TBIGRAT); })
/* MAYBE this is ugly..., maybe add exact/inexact flag, real, rational flag */
-#define ttisinexact(o_) \
- ({ TValue t_ = o_; \
- (ttisundef(t_) || ttisdouble(t_) || ttisrwnpv(t_) || ttisiinf(t_)); })
+#define ttisinexact(o_) \
+ ({ TValue t_ = o_; \
+ (ttisundef(t_) || ttisdouble(t_) || ttisrwnpv(t_) || ttisiinf(t_)); })
/* For now, all inexact numbers are not robust and have -inf & +inf bounds */
#define ttisrobust(o) (ttisexact(o))
#define ttisnumber(o) (ttype(o) <= K_LAST_NUMBER_TYPE)
#define ttiseinf(o) (tbasetype_(o) == K_TAG_EINF)
#define ttisiinf(o) (tbasetype_(o) == K_TAG_IINF)
-#define ttisinf(o_) \
- ({ TValue t_ = o_; \
- (ttiseinf(t_) || ttisiinf(t_)); })
+#define ttisinf(o_) \
+ ({ TValue t_ = o_; \
+ (ttiseinf(t_) || ttisiinf(t_)); })
#define ttisrwnpv(o) (tbasetype_(o) == K_TAG_RWNPV)
#define ttisundef(o) (tbasetype_(o) == K_TAG_UNDEFINED)
-#define ttisnwnpv(o_) \
- ({ TValue t_ = o_; \
- (ttisundef(t_) || ttisrwnpv(t_)); })
+#define ttisnwnpv(o_) \
+ ({ TValue t_ = o_; \
+ (ttisundef(t_) || ttisrwnpv(t_)); })
#define ttisnil(o) (tbasetype_(o) == K_TAG_NIL)
#define ttisignore(o) (tbasetype_(o) == K_TAG_IGNORE)
@@ -304,16 +304,16 @@ typedef struct __attribute__ ((__packed__)) GCheader {
(bigints, rationals, etc could be collectable)
maybe we should use a better way for this, to speed up checks, maybe use
a flag? */
-#define iscollectable(o) ({ uint8_t t = ttype(o); \
- (t == K_TBIGINT || t == K_TBIGRAT || t >= K_FIRST_GC_TYPE); })
+#define iscollectable(o) ({ uint8_t t = ttype(o); \
+ (t == K_TBIGINT || t == K_TBIGRAT || t >= K_FIRST_GC_TYPE); })
#define ttisstring(o) (tbasetype_(o) == K_TAG_STRING)
#define ttissymbol(o) (tbasetype_(o) == K_TAG_SYMBOL)
#define ttispair(o) (tbasetype_(o) == K_TAG_PAIR)
#define ttisoperative(o) (tbasetype_(o) == K_TAG_OPERATIVE)
#define ttisapplicative(o) (tbasetype_(o) == K_TAG_APPLICATIVE)
-#define ttiscombiner(o_) ({ int32_t t_ = tbasetype_(o_); \
- t_ == K_TAG_OPERATIVE || t_ == K_TAG_APPLICATIVE;})
+#define ttiscombiner(o_) ({ int32_t t_ = tbasetype_(o_); \
+ t_ == K_TAG_OPERATIVE || t_ == K_TAG_APPLICATIVE;})
#define ttisenvironment(o) (tbasetype_(o) == K_TAG_ENVIRONMENT)
#define ttiscontinuation(o) (tbasetype_(o) == K_TAG_CONTINUATION)
#define ttisencapsulation(o) (tbasetype_(o) == K_TAG_ENCAPSULATION)
@@ -323,8 +323,8 @@ typedef struct __attribute__ ((__packed__)) GCheader {
#define ttisbytevector(o) (tbasetype_(o) == K_TAG_BYTEVECTOR)
#define ttisfport(o) (tbasetype_(o) == K_TAG_FPORT)
#define ttismport(o) (tbasetype_(o) == K_TAG_MPORT)
-#define ttisport(o_) ({ int32_t t_ = tbasetype_(o_); \
- t_ == K_TAG_FPORT || t_ == K_TAG_MPORT;})
+#define ttisport(o_) ({ int32_t t_ = tbasetype_(o_); \
+ t_ == K_TAG_FPORT || t_ == K_TAG_MPORT;})
#define ttisvector(o) (tbasetype_(o) == K_TAG_VECTOR)
#define ttiskeyword(o) (tbasetype_(o) == K_TAG_KEYWORD)
#define ttismodule(o) (tbasetype_(o) == K_TAG_MODULE)
@@ -385,7 +385,7 @@ typedef struct __attribute__ ((__packed__)) {
typedef struct __attribute__ ((__packed__)) {
CommonHeader;
/* This is from IMath */
- Bigint num; /* Numerator */
+ Bigint num; /* Numerator */
Bigint den; /* Denominator, <> 0 */
} Bigrat;
@@ -407,8 +407,8 @@ typedef struct __attribute__ ((__packed__)) {
CommonHeader; /* symbols are marked via their strings */
TValue str; /* could use String * here, but for now... */
uint32_t hash; /* this is different from the str hash to
- avoid having both the string and the symbol
- from always falling in the same bucket */
+ avoid having both the string and the symbol
+ from always falling in the same bucket */
} Symbol;
typedef struct __attribute__ ((__packed__)) {
@@ -491,16 +491,16 @@ typedef struct __attribute__ ((__packed__)) {
*/
typedef union TKey {
- struct {
- TValue this; /* different from lua because of the tagging scheme */
- struct Node *next; /* for chaining */
- } nk;
- TValue tvk;
+ struct {
+ TValue this; /* different from lua because of the tagging scheme */
+ struct Node *next; /* for chaining */
+ } nk;
+ TValue tvk;
} TKey;
typedef struct Node {
- TValue i_val;
- TKey i_key;
+ TValue i_val;
+ TKey i_key;
} Node;
typedef struct __attribute__ ((__packed__)) {
@@ -549,8 +549,8 @@ typedef struct __attribute__ ((__packed__)) {
TValue mark; /* for cycle/sharing aware algorithms */
TValue str; /* could use String * here, but for now... */
uint32_t hash; /* this is different from the symbol & string hash
- to avoid having the string, the symbol, and the
- keyword always falling in the same bucket */
+ to avoid having the string, the symbol, and the
+ keyword always falling in the same bucket */
} Keyword;
typedef struct __attribute__ ((__packed__)) {
@@ -562,7 +562,7 @@ typedef struct __attribute__ ((__packed__)) {
/*
** `module' operation for hashing (size is always a power of 2)
*/
-#define lmod(s,size) \
+#define lmod(s,size) \
(check_exp((size&(size-1))==0, (cast(int32_t, (s) & ((size)-1)))))
@@ -595,8 +595,8 @@ typedef struct __attribute__ ((__packed__)) {
** Common header for markable objects
*/
typedef struct __attribute__ ((__packed__)) {
- CommonHeader;
- TValue mark;
+ CommonHeader;
+ TValue mark;
} MGCheader;
/*
@@ -696,16 +696,16 @@ const TValue kfree;
#define b2tv_(b_) {.tv = {.t = K_TAG_BOOLEAN, .v = { .b = (b_) }}}
#define p2tv_(p_) {.tv = {.t = K_TAG_USER, .v = { .p = (p_) }}}
#define d2tv_(d_) {.d = d_}
-#define ktag_double(d_) \
- ({ double d__ = d_; \
- TValue res__; \
- if (isnan(d__)) res__ = KRWNPV; \
- else if (isinf(d__)) res__ = (d__ == INFINITY)? \
- KIPINF : KIMINF; \
- /* +0.0 == -0.0 too, but that doesn't hurt */ \
- else if (d__ == -0.0) res__ = d2tv(+0.0); \
- else res__ = d2tv(d__); \
- res__;})
+#define ktag_double(d_) \
+ ({ double d__ = d_; \
+ TValue res__; \
+ if (isnan(d__)) res__ = KRWNPV; \
+ else if (isinf(d__)) res__ = (d__ == INFINITY)? \
+ KIPINF : KIMINF; \
+ /* +0.0 == -0.0 too, but that doesn't hurt */ \
+ else if (d__ == -0.0) res__ = d2tv(+0.0); \
+ else res__ = d2tv(d__); \
+ res__;})
/* Macros to create TValues of non-heap allocated types */
#define ch2tv(ch_) ((TValue) ch2tv_(ch_))
@@ -718,8 +718,8 @@ const TValue kfree;
/* TODO: add assertions */
/* REFACTOR: change names to bigint2tv, pair2tv, etc */
/* LUA NOTE: the corresponding defines are in lstate.h */
-#define gc2tv(t_, o_) ((TValue) {.tv = {.t = (t_), \
- .v = { .gc = obj2gco(o_)}}})
+#define gc2tv(t_, o_) ((TValue) {.tv = {.t = (t_), \
+ .v = { .gc = obj2gco(o_)}}})
#define gc2bigint(o_) (gc2tv(K_TAG_BIGINT, o_))
#define gc2bigrat(o_) (gc2tv(K_TAG_BIGRAT, o_))
#define gc2pair(o_) (gc2tv(K_TAG_PAIR, o_))
@@ -795,14 +795,14 @@ extern char *ktv_names[];
/* XXX: marking macros should take a klisp_State parameter and
keep track of marks in the klisp_State */
int32_t kmark_count;
-#define kset_mark(p_, m_) ({ TValue new_mark_ = (m_); \
- TValue obj_ = (p_); \
- TValue old_mark_ = kget_mark(p_); \
- if (kis_false(old_mark_) && !kis_false(new_mark_)) \
- ++kmark_count; \
- else if (kis_false(new_mark_) && !kis_false(old_mark_)) \
- --kmark_count; \
- kget_mark(obj_) = new_mark_; })
+#define kset_mark(p_, m_) ({ TValue new_mark_ = (m_); \
+ TValue obj_ = (p_); \
+ TValue old_mark_ = kget_mark(p_); \
+ if (kis_false(old_mark_) && !kis_false(new_mark_)) \
+ ++kmark_count; \
+ else if (kis_false(new_mark_) && !kis_false(old_mark_)) \
+ --kmark_count; \
+ kget_mark(obj_) = new_mark_; })
#define kcheck_mark_balance() (assert(kmark_count == 0))
#else
#define kset_mark(p_, m_) (kget_mark(p_) = (m_))
@@ -840,17 +840,17 @@ int32_t kmark_count;
#define K_FLAG_HAS_NAME 0x40
/* evaluates o_ more than once */
-#define kcan_have_name(o_) \
+#define kcan_have_name(o_) \
(iscollectable(o_) && ((tv_get_kflags(o_)) & K_FLAG_CAN_HAVE_NAME) != 0)
-#define khas_name(o_) \
+#define khas_name(o_) \
(iscollectable(o_) && (tv_get_kflags(o_)) & K_FLAG_HAS_NAME)
#define K_FLAG_HAS_SI 0x20
#define kcan_have_si(o_) (iscollectable(o_))
-#define khas_si(o_) ((iscollectable(o_) && \
- (tv_get_kflags(o_)) & K_FLAG_HAS_SI))
+#define khas_si(o_) ((iscollectable(o_) && \
+ (tv_get_kflags(o_)) & K_FLAG_HAS_SI))
#define K_FLAG_IMMUTABLE 0x10
@@ -901,27 +901,27 @@ int32_t kmark_count;
#define K_FLAG_WEAK_VALUES 0x02
#define K_FLAG_WEAK_NOTHING 0x00
-#define ktable_has_weak_keys(o_) \
+#define ktable_has_weak_keys(o_) \
((tv_get_kflags(o_) & K_FLAG_WEAK_KEYS) != 0)
-#define ktable_has_weak_values(o_) \
+#define ktable_has_weak_values(o_) \
((tv_get_kflags(o_) & K_FLAG_WEAK_VALUES) != 0)
/* Macro to test the most basic equality on TValues */
#define tv_equal(tv1_, tv2_) ((tv1_).raw == (tv2_).raw)
/* Symbols could be eq? but not tv_equal? because of source info */
-#define tv_sym_equal(sym1_, sym2_) \
+#define tv_sym_equal(sym1_, sym2_) \
(tv_equal(tv2sym(sym1_)->str, tv2sym(sym2_)->str))
/*
** for internal debug only
*/
-#define checkconsistency(obj) \
- klisp_assert(!iscollectable(obj) || (ttype_(obj) == gcvalue(obj)->gch.tt))
+#define checkconsistency(obj) \
+ klisp_assert(!iscollectable(obj) || (ttype_(obj) == gcvalue(obj)->gch.tt))
-#define checkliveness(k,obj) \
- klisp_assert(!iscollectable(obj) || \
- ((ttype_(obj) == gcvalue(obj)->gch.tt) && !isdead(k, gcvalue(obj))))
+#define checkliveness(k,obj) \
+ klisp_assert(!iscollectable(obj) || \
+ ((ttype_(obj) == gcvalue(obj)->gch.tt) && !isdead(k, gcvalue(obj))))
#endif
diff --git a/src/koperative.c b/src/koperative.c
@@ -18,11 +18,11 @@ TValue kmake_operative(klisp_State *K, klisp_CFunction fn, int32_t xcount, ...)
va_list argp;
Operative *new_op = (Operative *)
- klispM_malloc(K, sizeof(Operative) + sizeof(TValue) * xcount);
+ klispM_malloc(K, sizeof(Operative) + sizeof(TValue) * xcount);
/* header + gc_fields */
klispC_link(K, (GCObject *) new_op, K_TOPERATIVE,
- K_FLAG_CAN_HAVE_NAME);
+ K_FLAG_CAN_HAVE_NAME);
/* operative specific fields */
new_op->fn = fn;
@@ -30,7 +30,7 @@ TValue kmake_operative(klisp_State *K, klisp_CFunction fn, int32_t xcount, ...)
va_start(argp, xcount);
for (int i = 0; i < xcount; i++) {
- new_op->extra[i] = va_arg(argp, TValue);
+ new_op->extra[i] = va_arg(argp, TValue);
}
va_end(argp);
diff --git a/src/koperative.h b/src/koperative.h
@@ -14,6 +14,6 @@
/* GC: Assumes all argps are rooted */
TValue kmake_operative(klisp_State *K, klisp_CFunction fn, int32_t xcount,
- ...);
+ ...);
#endif
diff --git a/src/kpair.c b/src/kpair.c
@@ -43,10 +43,10 @@ TValue klist_g(klisp_State *K, bool m, int32_t n, ...)
va_start(argp, n);
for (int i = 0; i < n; i++) {
- TValue next_car = va_arg(argp, TValue);
- TValue np = kcons_g(K, m, next_car, KNIL);
- kset_cdr_unsafe(K, tail, np);
- tail = np;
+ TValue next_car = va_arg(argp, TValue);
+ TValue np = kcons_g(K, m, next_car, KNIL);
+ kset_cdr_unsafe(K, tail, np);
+ tail = np;
}
va_end(argp);
diff --git a/src/kpair.h b/src/kpair.h
@@ -74,7 +74,7 @@ inline void kset_cdr(TValue p, TValue v)
}
/* These two are the same but can write immutable pairs,
- use with care */
+ use with care */
inline void kset_car_unsafe(klisp_State *K, TValue p, TValue v)
{
klisp_assert(kpairp(p));
diff --git a/src/kport.c b/src/kport.c
@@ -82,35 +82,35 @@ TValue kmake_fport(klisp_State *K, TValue filename, bool writep, bool binaryp)
/* for now always use text mode */
char *mode;
if (binaryp)
- mode = writep? "wb": "rb";
+ mode = writep? "wb": "rb";
else
- mode = writep? "w": "r";
+ mode = writep? "w": "r";
FILE *f = fopen(kstring_buf(filename), mode);
if (f == NULL) {
- TValue mode_str = kstring_new_b(K, mode);
- krooted_tvs_push(K, mode_str);
+ TValue mode_str = kstring_new_b(K, mode);
+ krooted_tvs_push(K, mode_str);
klispE_throw_errno_with_irritants(K, "fopen", 2, filename, mode_str);
- return KINERT;
+ return KINERT;
} else {
- return kmake_std_fport(K, filename, writep, binaryp, f);
+ return kmake_std_fport(K, filename, writep, binaryp, f);
}
}
/* this is for creating ports for stdin/stdout/stderr &
- also a helper for the above */
+ also a helper for the above */
/* GC: Assumes filename, name & si are rooted */
TValue kmake_std_fport(klisp_State *K, TValue filename, bool writep,
- bool binaryp, FILE *file)
+ bool binaryp, FILE *file)
{
FPort *new_port = klispM_new(K, FPort);
/* header + gc_fields */
klispC_link(K, (GCObject *) new_port, K_TFPORT,
- K_FLAG_CAN_HAVE_NAME |
- (writep? K_FLAG_OUTPUT_PORT : K_FLAG_INPUT_PORT) |
- (binaryp? K_FLAG_BINARY_PORT : 0));
+ K_FLAG_CAN_HAVE_NAME |
+ (writep? K_FLAG_OUTPUT_PORT : K_FLAG_INPUT_PORT) |
+ (binaryp? K_FLAG_BINARY_PORT : 0));
/* port specific fields */
new_port->filename = filename;
@@ -127,11 +127,11 @@ TValue kmake_mport(klisp_State *K, TValue buffer, bool writep, bool binaryp)
{
klisp_assert(!writep || ttisinert(buffer));
klisp_assert(writep || (ttisbytevector(buffer) && binaryp) ||
- (ttisstring(buffer) && !binaryp));
+ (ttisstring(buffer) && !binaryp));
if (writep) {
- buffer = binaryp? kbytevector_new_s(K, MINBYTEVECTORPORTBUFFER) :
- kstring_new_s(K, MINSTRINGPORTBUFFER);
+ buffer = binaryp? kbytevector_new_s(K, MINBYTEVECTORPORTBUFFER) :
+ kstring_new_s(K, MINSTRINGPORTBUFFER);
}
krooted_tvs_push(K, buffer);
@@ -140,9 +140,9 @@ TValue kmake_mport(klisp_State *K, TValue buffer, bool writep, bool binaryp)
/* header + gc_fields */
klispC_link(K, (GCObject *) new_port, K_TMPORT,
- K_FLAG_CAN_HAVE_NAME |
- (writep? K_FLAG_OUTPUT_PORT : K_FLAG_INPUT_PORT) |
- (binaryp? K_FLAG_BINARY_PORT : 0));
+ K_FLAG_CAN_HAVE_NAME |
+ (writep? K_FLAG_OUTPUT_PORT : K_FLAG_INPUT_PORT) |
+ (binaryp? K_FLAG_BINARY_PORT : 0));
/* port specific fields */
TValue tv_port = gc2mport(new_port);
@@ -163,12 +163,12 @@ void kclose_port(klisp_State *K, TValue port)
assert(ttisport(port));
if (!kport_is_closed(port)) {
- if (ttisfport(port)) {
- FILE *f = tv2fport(port)->file;
- if (f != stdin && f != stderr && f != stdout)
- fclose(f); /* it isn't necessary to check the close ret val */
- }
- kport_set_closed(port);
+ if (ttisfport(port)) {
+ FILE *f = tv2fport(port)->file;
+ if (f != stdin && f != stderr && f != stdout)
+ fclose(f); /* it isn't necessary to check the close ret val */
+ }
+ kport_set_closed(port);
}
return;
@@ -195,36 +195,36 @@ void kmport_resize_buffer(klisp_State *K, TValue port, size_t min_size)
klisp_assert(kport_is_output(port));
uint32_t old_size = (kport_is_binary(port))?
- kbytevector_size(kmport_buf(port)) :
- kstring_size(kmport_buf(port));
+ kbytevector_size(kmport_buf(port)) :
+ kstring_size(kmport_buf(port));
uint64_t new_size = old_size;
while (new_size < min_size) {
- new_size *= 2;
- if (new_size > SIZE_MAX)
- klispM_toobig(K);
+ new_size *= 2;
+ if (new_size > SIZE_MAX)
+ klispM_toobig(K);
}
if (new_size == old_size)
- return;
+ return;
if (kport_is_binary(port)) {
- TValue new_bb = kbytevector_new_s(K, new_size);
- uint32_t off = kmport_off(port);
- if (off != 0) {
- memcpy(kbytevector_buf(new_bb),
- kbytevector_buf(kmport_buf(port)),
- off);
- }
- kmport_buf(port) = new_bb;
+ TValue new_bb = kbytevector_new_s(K, new_size);
+ uint32_t off = kmport_off(port);
+ if (off != 0) {
+ memcpy(kbytevector_buf(new_bb),
+ kbytevector_buf(kmport_buf(port)),
+ off);
+ }
+ kmport_buf(port) = new_bb;
} else {
- TValue new_str = kstring_new_s(K, new_size);
- uint32_t off = kmport_off(port);
- if (off != 0) {
- memcpy(kstring_buf(new_str),
- kstring_buf(kmport_buf(port)),
- off);
- }
- kmport_buf(port) = new_str;
+ TValue new_str = kstring_new_s(K, new_size);
+ uint32_t off = kmport_off(port);
+ if (off != 0) {
+ memcpy(kstring_buf(new_str),
+ kstring_buf(kmport_buf(port)),
+ off);
+ }
+ kmport_buf(port) = new_str;
}
}
diff --git a/src/kport.h b/src/kport.h
@@ -13,7 +13,7 @@
#include "kstate.h"
/* can't be inline because we also use pointers to them,
- (at least gcc doesn't bother to create them and the linker fails) */
+ (at least gcc doesn't bother to create them and the linker fails) */
bool kportp(TValue o);
bool kinput_portp(TValue o);
bool koutput_portp(TValue o);
@@ -29,10 +29,10 @@ bool kport_closedp(TValue o);
TValue kmake_fport(klisp_State *K, TValue filename, bool writep, bool binaryp);
/* this is for creating ports for stdin/stdout/stderr &
- helper for the one above */
+ helper for the one above */
/* GC: Assumes filename, name & si are rooted */
TValue kmake_std_fport(klisp_State *K, TValue filename, bool writep,
- bool binaryp, FILE *file);
+ bool binaryp, FILE *file);
/* GC: buffer doesn't need to be rooted, but should probably do it anyways */
TValue kmake_mport(klisp_State *K, TValue buffer, bool writep, bool binaryp);
diff --git a/src/krational.c b/src/krational.c
@@ -21,7 +21,7 @@
/* used for res & temps in operations */
/* NOTE: This is to be called only with already reduced values */
TValue kbigrat_new(klisp_State *K, bool sign, uint32_t num,
- uint32_t den)
+ uint32_t den)
{
Bigrat *new_bigrat = klispM_new(K, Bigrat);
@@ -61,12 +61,12 @@ TValue kbigrat_copy(klisp_State *K, TValue src)
*/
/* this works for bigrats, bigints & fixints, returns true if ok */
bool krational_read(klisp_State *K, char *buf, int32_t base, TValue *out,
- char **end)
+ char **end)
{
TValue res = kbigrat_make_simple(K);
krooted_tvs_push(K, res);
bool ret_val = (mp_rat_read_cstring(K, tv2bigrat(res), base,
- buf, end) == MP_OK);
+ buf, end) == MP_OK);
krooted_tvs_pop(K);
*out = kbigrat_try_integer(K, res);
@@ -74,11 +74,11 @@ bool krational_read(klisp_State *K, char *buf, int32_t base, TValue *out,
/* detect sign after '/', and / before numbers, those are allowed
by imrat but not in kernel */
if (ret_val) {
- char *slash = strchr(buf, '/');
- if (slash != NULL && (slash == 0 ||
- (*(slash+1) == '+' || *(slash+1) == '-') ||
- (*(slash-1) == '+' || *(slash-1) == '-')))
- ret_val = false;
+ char *slash = strchr(buf, '/');
+ if (slash != NULL && (slash == 0 ||
+ (*(slash+1) == '+' || *(slash+1) == '-') ||
+ (*(slash-1) == '+' || *(slash-1) == '-')))
+ ret_val = false;
}
return ret_val;
@@ -86,74 +86,74 @@ bool krational_read(klisp_State *K, char *buf, int32_t base, TValue *out,
/* NOTE: allow decimal for use after #e */
bool krational_read_decimal(klisp_State *K, char *buf, int32_t base, TValue *out,
- char **end, bool *out_decimalp)
+ char **end, bool *out_decimalp)
{
/* NOTE: in Kernel only base ten is allowed in decimal format */
klisp_assert(base == 10);
char *my_end;
if (!end) /* always get the last char not read */
- end = &my_end;
+ end = &my_end;
TValue res = kbigrat_make_simple(K);
krooted_tvs_push(K, res);
mp_result ret_val = mp_rat_read_ustring(K, tv2bigrat(res), base,
- buf, end);
+ buf, end);
/* check to see if there was a decimal point, will only
- be written to out_decimalp if no error ocurr */
+ be written to out_decimalp if no error ocurr */
/* TEMP: mp_rat_read_ustring does not set *end if an error occurs.
* Do not let memchr() read past the end of the buffer. */
bool decimalp = (ret_val == MP_OK || ret_val == MP_TRUNC)
- ? (memchr(buf, '.', *end - buf) != NULL)
- : false;
+ ? (memchr(buf, '.', *end - buf) != NULL)
+ : false;
/* handle exponents, avoid the case where the number finishes
- in a decimal point (this isn't allowed by kernel */
+ in a decimal point (this isn't allowed by kernel */
if (decimalp && ret_val == MP_TRUNC && *end != buf &&
- *((*end)-1) != '.') {
- char *ebuf = *end;
- char el = tolower(*ebuf);
- /* NOTE: in klisp all exponent letters map to double */
- if (el == 'e' || el == 's' || el == 'f' || el == 'd' || el == 'l') {
- ebuf++;
- TValue tv_exp_exp = kbigint_make_simple(K);
- krooted_tvs_push(K, tv_exp_exp);
- Bigint *exp_exp = tv2bigint(tv_exp_exp);
- /* base should be 10 */
- ret_val = mp_int_read_cstring(K, exp_exp, base, ebuf, end);
- if (ret_val == MP_OK) {
- /* IMath doesn't have general rational exponentiation,
- so do it manually */
- TValue tv_iexp = kbigint_make_simple(K);
- krooted_tvs_push(K, tv_iexp);
- Bigint *iexp = tv2bigint(tv_iexp);
- UNUSED(mp_int_set_value(K, iexp, 10));
- bool negativep = mp_int_compare_zero(exp_exp) < 0;
- UNUSED(mp_int_abs(K, exp_exp, exp_exp));
- UNUSED(mp_int_expt_full(K, iexp, exp_exp, iexp));
- /* iexp has 10^|exp_exp| */
- if (negativep) {
- TValue tv_rexp = kbigrat_make_simple(K);
- krooted_tvs_push(K, tv_rexp);
- Bigrat *rexp = tv2bigrat(tv_rexp);
- /* copy reciprocal of iexp to rexp */
- UNUSED(mp_rat_zero(K, rexp));
- UNUSED(mp_rat_add_int(K, rexp, iexp, rexp));
- UNUSED(mp_rat_recip(K, rexp, rexp));
- /* now get true number */
- UNUSED(mp_rat_mul(K, tv2bigrat(res), rexp,
- tv2bigrat(res)));
- krooted_tvs_pop(K); /* rexp */
- } else { /* exponent positive, can just mult int */
- UNUSED(mp_rat_mul_int(K, tv2bigrat(res), iexp,
- tv2bigrat(res)));
- }
- krooted_tvs_pop(K); /* iexp */
- /* fall through, ret_val remains MP_OK */
- } /* else, fall through, ret_val remains != MP_OK */
- krooted_tvs_pop(K); /* exp_exp */
- }
+ *((*end)-1) != '.') {
+ char *ebuf = *end;
+ char el = tolower(*ebuf);
+ /* NOTE: in klisp all exponent letters map to double */
+ if (el == 'e' || el == 's' || el == 'f' || el == 'd' || el == 'l') {
+ ebuf++;
+ TValue tv_exp_exp = kbigint_make_simple(K);
+ krooted_tvs_push(K, tv_exp_exp);
+ Bigint *exp_exp = tv2bigint(tv_exp_exp);
+ /* base should be 10 */
+ ret_val = mp_int_read_cstring(K, exp_exp, base, ebuf, end);
+ if (ret_val == MP_OK) {
+ /* IMath doesn't have general rational exponentiation,
+ so do it manually */
+ TValue tv_iexp = kbigint_make_simple(K);
+ krooted_tvs_push(K, tv_iexp);
+ Bigint *iexp = tv2bigint(tv_iexp);
+ UNUSED(mp_int_set_value(K, iexp, 10));
+ bool negativep = mp_int_compare_zero(exp_exp) < 0;
+ UNUSED(mp_int_abs(K, exp_exp, exp_exp));
+ UNUSED(mp_int_expt_full(K, iexp, exp_exp, iexp));
+ /* iexp has 10^|exp_exp| */
+ if (negativep) {
+ TValue tv_rexp = kbigrat_make_simple(K);
+ krooted_tvs_push(K, tv_rexp);
+ Bigrat *rexp = tv2bigrat(tv_rexp);
+ /* copy reciprocal of iexp to rexp */
+ UNUSED(mp_rat_zero(K, rexp));
+ UNUSED(mp_rat_add_int(K, rexp, iexp, rexp));
+ UNUSED(mp_rat_recip(K, rexp, rexp));
+ /* now get true number */
+ UNUSED(mp_rat_mul(K, tv2bigrat(res), rexp,
+ tv2bigrat(res)));
+ krooted_tvs_pop(K); /* rexp */
+ } else { /* exponent positive, can just mult int */
+ UNUSED(mp_rat_mul_int(K, tv2bigrat(res), iexp,
+ tv2bigrat(res)));
+ }
+ krooted_tvs_pop(K); /* iexp */
+ /* fall through, ret_val remains MP_OK */
+ } /* else, fall through, ret_val remains != MP_OK */
+ krooted_tvs_pop(K); /* exp_exp */
+ }
}
/* TODO: ideally this should be incorporated in the read code */
@@ -161,28 +161,28 @@ bool krational_read_decimal(klisp_State *K, char *buf, int32_t base, TValue *out
/* detect sign after '/', or trailing '.' or starting '/' or '.'.
Those are allowed by imrat but not by kernel */
if (ret_val == MP_OK) {
- char *ch = strchr(buf, '/');
- if (ch != NULL && (ch == 0 ||
- (*(ch+1) == '+' || *(ch+1) == '-') ||
- (*(ch-1) == '+' || *(ch-1) == '-'))) {
- ret_val = MP_TRUNC;
- } else {
- ch = strchr(buf, '.');
- if (ch != NULL && (ch == 0 ||
- (*(ch+1) == '+' || *(ch+1) == '-') ||
- (*(ch-1) == '+' || *(ch-1) == '-') ||
- ch == *end - 1)) {
- ret_val = MP_TRUNC;
- }
- }
+ char *ch = strchr(buf, '/');
+ if (ch != NULL && (ch == 0 ||
+ (*(ch+1) == '+' || *(ch+1) == '-') ||
+ (*(ch-1) == '+' || *(ch-1) == '-'))) {
+ ret_val = MP_TRUNC;
+ } else {
+ ch = strchr(buf, '.');
+ if (ch != NULL && (ch == 0 ||
+ (*(ch+1) == '+' || *(ch+1) == '-') ||
+ (*(ch-1) == '+' || *(ch-1) == '-') ||
+ ch == *end - 1)) {
+ ret_val = MP_TRUNC;
+ }
+ }
}
if (ret_val == MP_OK && out_decimalp != NULL)
- *out_decimalp = decimalp;
+ *out_decimalp = decimalp;
krooted_tvs_pop(K);
if (ret_val == MP_OK) {
- *out = kbigrat_try_integer(K, res);
+ *out = kbigrat_try_integer(K, res);
}
return ret_val == MP_OK;
@@ -198,11 +198,11 @@ int32_t kbigrat_print_size(TValue tv_bigrat, int32_t base)
/* this is used by write */
void kbigrat_print_string(klisp_State *K, TValue tv_bigrat, int32_t base,
- char *buf, int32_t limit)
+ char *buf, int32_t limit)
{
klisp_assert(ttisbigrat(tv_bigrat));
mp_result res = mp_rat_to_string(K, tv2bigrat(tv_bigrat), base, buf,
- limit);
+ limit);
/* only possible error is truncation */
klisp_assert(res == MP_OK);
}
@@ -214,31 +214,31 @@ void kbigrat_print_string(klisp_State *K, TValue tv_bigrat, int32_t base,
bool kbigrat_eqp(klisp_State *K, TValue tv_bigrat1, TValue tv_bigrat2)
{
return (mp_rat_compare(K, tv2bigrat(tv_bigrat1),
- tv2bigrat(tv_bigrat2)) == 0);
+ tv2bigrat(tv_bigrat2)) == 0);
}
bool kbigrat_ltp(klisp_State *K, TValue tv_bigrat1, TValue tv_bigrat2)
{
return (mp_rat_compare(K, tv2bigrat(tv_bigrat1),
- tv2bigrat(tv_bigrat2)) < 0);
+ tv2bigrat(tv_bigrat2)) < 0);
}
bool kbigrat_lep(klisp_State *K, TValue tv_bigrat1, TValue tv_bigrat2)
{
return (mp_rat_compare(K, tv2bigrat(tv_bigrat1),
- tv2bigrat(tv_bigrat2)) <= 0);
+ tv2bigrat(tv_bigrat2)) <= 0);
}
bool kbigrat_gtp(klisp_State *K, TValue tv_bigrat1, TValue tv_bigrat2)
{
return (mp_rat_compare(K, tv2bigrat(tv_bigrat1),
- tv2bigrat(tv_bigrat2)) > 0);
+ tv2bigrat(tv_bigrat2)) > 0);
}
bool kbigrat_gep(klisp_State *K, TValue tv_bigrat1, TValue tv_bigrat2)
{
return (mp_rat_compare(K, tv2bigrat(tv_bigrat1),
- tv2bigrat(tv_bigrat2)) >= 0);
+ tv2bigrat(tv_bigrat2)) >= 0);
}
/*
@@ -299,7 +299,7 @@ TValue kbigrat_div_mod(klisp_State *K, TValue n1, TValue n2, TValue *res_r)
/* Now use the integral part as the quotient and the fractional part times
the divisor as the remainder, but then correct the remainder so that it's
always positive like in kbigint_div_and_mod */
-
+
UNUSED(mp_int_div(K, MP_NUMER_P(div), MP_DENOM_P(div), q, r));
/* NOTE: denom is positive, so div & q & r have the same sign */
@@ -307,7 +307,7 @@ TValue kbigrat_div_mod(klisp_State *K, TValue n1, TValue n2, TValue *res_r)
/* first adjust the quotient if necessary,
the remainder will just fall into place after this */
if (mp_rat_compare_zero(n) < 0)
- UNUSED(mp_int_add_value(K, q, mp_rat_compare_zero(d) < 0? 1 : -1, q));
+ UNUSED(mp_int_add_value(K, q, mp_rat_compare_zero(d) < 0? 1 : -1, q));
UNUSED(mp_rat_sub_int(K, div, q, trem));
UNUSED(mp_rat_mul(K, trem, d, trem));
@@ -348,7 +348,7 @@ TValue kbigrat_div0_mod0(klisp_State *K, TValue n1, TValue n2, TValue *res_r)
/* Now use the integral part as the quotient and the fractional part times
the divisor as the remainder, but then correct the remainder so that it's
in the interval [-|d/2|, |d/2|) */
-
+
UNUSED(mp_int_div(K, MP_NUMER_P(div), MP_DENOM_P(div), q, r));
/* NOTE: denom is positive, so div & q & r have the same sign */
UNUSED(mp_rat_sub_int(K, div, q, trem));
@@ -367,25 +367,25 @@ TValue kbigrat_div0_mod0(klisp_State *K, TValue n1, TValue n2, TValue *res_r)
/* the case analysis is like in bigint (and inverse to that of fixint) */
if (mp_rat_compare(K, trem, d_2) >= 0) {
- if (mp_rat_compare_zero(d) < 0) {
- mp_rat_add(K, trem, d, trem);
- mp_int_sub_value(K, q, 1, q);
- } else {
- mp_rat_sub(K, trem, d, trem);
- mp_int_add_value(K, q, 1, q);
- }
+ if (mp_rat_compare_zero(d) < 0) {
+ mp_rat_add(K, trem, d, trem);
+ mp_int_sub_value(K, q, 1, q);
+ } else {
+ mp_rat_sub(K, trem, d, trem);
+ mp_int_add_value(K, q, 1, q);
+ }
} else {
- /* now check negative side (open part of the interval) */
- mp_rat_neg(K, d_2, d_2);
- if (mp_rat_compare(K, trem, d_2) < 0) {
- if (mp_rat_compare_zero(d) < 0) {
- mp_rat_sub(K, trem, d, trem);
- mp_int_add_value(K, q, 1, q);
- } else {
- mp_rat_add(K, trem, d, trem);
- mp_int_sub_value(K, q, 1, q);
- }
- }
+ /* now check negative side (open part of the interval) */
+ mp_rat_neg(K, d_2, d_2);
+ if (mp_rat_compare(K, trem, d_2) < 0) {
+ if (mp_rat_compare_zero(d) < 0) {
+ mp_rat_sub(K, trem, d, trem);
+ mp_int_add_value(K, q, 1, q);
+ } else {
+ mp_rat_add(K, trem, d, trem);
+ mp_int_sub_value(K, q, 1, q);
+ }
+ }
}
krooted_tvs_pop(K); /* d/2 */
@@ -424,14 +424,14 @@ bool kbigrat_positivep(TValue tv_bigrat)
TValue kbigrat_abs(klisp_State *K, TValue tv_bigrat)
{
if (kbigrat_negativep(tv_bigrat)) {
- TValue copy = kbigrat_make_simple(K);
- krooted_tvs_push(K, copy);
- UNUSED(mp_rat_abs(K, tv2bigrat(tv_bigrat), tv2bigrat(copy)));
- krooted_tvs_pop(K);
- /* NOTE: this can never be an integer if the parameter was a bigrat */
- return copy;
+ TValue copy = kbigrat_make_simple(K);
+ krooted_tvs_push(K, copy);
+ UNUSED(mp_rat_abs(K, tv2bigrat(tv_bigrat), tv2bigrat(copy)));
+ krooted_tvs_pop(K);
+ /* NOTE: this can never be an integer if the parameter was a bigrat */
+ return copy;
} else {
- return tv_bigrat;
+ return tv_bigrat;
}
}
@@ -440,15 +440,15 @@ TValue kbigrat_numerator(klisp_State *K, TValue tv_bigrat)
int32_t fnum = 0;
Bigrat *bigrat = tv2bigrat(tv_bigrat);
if (mp_rat_to_ints(bigrat, &fnum, NULL) == MP_OK)
- return i2tv(fnum);
+ return i2tv(fnum);
else {
- TValue copy = kbigint_make_simple(K);
- krooted_tvs_push(K, copy);
- UNUSED(mp_rat_numer(K, bigrat, tv2bigint(copy)));
- krooted_tvs_pop(K);
- /* NOTE: may still be a fixint because mp_rat_to_ints fails if
- either numer or denom isn't a fixint */
- return kbigint_try_fixint(K, copy);
+ TValue copy = kbigint_make_simple(K);
+ krooted_tvs_push(K, copy);
+ UNUSED(mp_rat_numer(K, bigrat, tv2bigint(copy)));
+ krooted_tvs_pop(K);
+ /* NOTE: may still be a fixint because mp_rat_to_ints fails if
+ either numer or denom isn't a fixint */
+ return kbigint_try_fixint(K, copy);
}
}
@@ -457,15 +457,15 @@ TValue kbigrat_denominator(klisp_State *K, TValue tv_bigrat)
int32_t fden = 0;
Bigrat *bigrat = tv2bigrat(tv_bigrat);
if (mp_rat_to_ints(bigrat, NULL, &fden) == MP_OK)
- return i2tv(fden);
+ return i2tv(fden);
else {
- TValue copy = kbigint_make_simple(K);
- krooted_tvs_push(K, copy);
- UNUSED(mp_rat_denom(K, bigrat, tv2bigint(copy)));
- krooted_tvs_pop(K);
- /* NOTE: may still be a fixint because mp_rat_to_ints fails if
- either numer or denom isn't a fixint */
- return kbigint_try_fixint(K, copy);
+ TValue copy = kbigint_make_simple(K);
+ krooted_tvs_push(K, copy);
+ UNUSED(mp_rat_denom(K, bigrat, tv2bigint(copy)));
+ krooted_tvs_pop(K);
+ /* NOTE: may still be a fixint because mp_rat_to_ints fails if
+ either numer or denom isn't a fixint */
+ return kbigint_try_fixint(K, copy);
}
}
@@ -484,28 +484,28 @@ TValue kbigrat_to_integer(klisp_State *K, TValue tv_bigrat, kround_mode mode)
UNUSED(mp_int_div(K, quot, MP_DENOM_P(n), quot, rest));
if (mp_rat_compare_zero(n) < 0)
- UNUSED(mp_int_neg(K, quot, quot));
+ UNUSED(mp_int_neg(K, quot, quot));
switch(mode) {
case K_TRUNCATE:
- /* nothing needs to be done */
- break;
+ /* nothing needs to be done */
+ break;
case K_CEILING:
- if (mp_rat_compare_zero(n) > 0 && mp_int_compare_zero(rest) != 0)
- UNUSED(mp_int_add_value(K, quot, 1, quot));
- break;
+ if (mp_rat_compare_zero(n) > 0 && mp_int_compare_zero(rest) != 0)
+ UNUSED(mp_int_add_value(K, quot, 1, quot));
+ break;
case K_FLOOR:
- if (mp_rat_compare_zero(n) < 0 && mp_int_compare_zero(rest) != 0)
- UNUSED(mp_int_sub_value(K, quot, 1, quot));
- break;
+ if (mp_rat_compare_zero(n) < 0 && mp_int_compare_zero(rest) != 0)
+ UNUSED(mp_int_sub_value(K, quot, 1, quot));
+ break;
case K_ROUND_EVEN: {
- UNUSED(mp_int_mul_pow2(K, rest, 1, rest));
- int cmp = mp_int_compare(rest, MP_DENOM_P(n));
- if (cmp > 0 || (cmp == 0 && mp_int_is_odd(quot))) {
- UNUSED(mp_int_add_value(K, quot, mp_rat_compare_zero(n) < 0?
- -1 : 1, quot));
- }
- break;
+ UNUSED(mp_int_mul_pow2(K, rest, 1, rest));
+ int cmp = mp_int_compare(rest, MP_DENOM_P(n));
+ if (cmp > 0 || (cmp == 0 && mp_int_is_odd(quot))) {
+ UNUSED(mp_int_add_value(K, quot, mp_rat_compare_zero(n) < 0?
+ -1 : 1, quot));
+ }
+ break;
}
}
@@ -518,22 +518,22 @@ TValue kbigrat_to_integer(klisp_State *K, TValue tv_bigrat, kround_mode mode)
** SOURCE NOTE: this implementation is from the Haskell 98 report
*/
/*
-approxRational x eps = simplest (x-eps) (x+eps)
- where simplest x y | y < x = simplest y x
- | x == y = xr
- | x > 0 = simplest' n d n' d'
- | y < 0 = - simplest' (-n') d' (-n) d
- | otherwise = 0 :% 1
- where xr@(n:%d) = toRational x
- (n':%d') = toRational y
-
- simplest' n d n' d' -- assumes 0 < n%d < n'%d'
- | r == 0 = q :% 1
- | q /= q' = (q+1) :% 1
- | otherwise = (q*n''+d'') :% n''
- where (q,r) = quotRem n d
- (q',r') = quotRem n' d'
- (n'':%d'') = simplest' d' r' d r
+ approxRational x eps = simplest (x-eps) (x+eps)
+ where simplest x y | y < x = simplest y x
+ | x == y = xr
+ | x > 0 = simplest' n d n' d'
+ | y < 0 = - simplest' (-n') d' (-n) d
+ | otherwise = 0 :% 1
+ where xr@(n:%d) = toRational x
+ (n':%d') = toRational y
+
+ simplest' n d n' d' -- assumes 0 < n%d < n'%d'
+ | r == 0 = q :% 1
+ | q /= q' = (q+1) :% 1
+ | otherwise = (q*n''+d'') :% n''
+ where (q,r) = quotRem n d
+ (q',r') = quotRem n' d'
+ (n'':%d'') = simplest' d' r' d r
*/
@@ -548,7 +548,7 @@ approxRational x eps = simplest (x-eps) (x+eps)
/* Assumes 0 < n1/d1 < n2/d2 */
/* GC: Assumes n1, d1, n2, d2, and res are fresh (can be mutated) and rooted */
static void simplest(klisp_State *K, TValue tv_n1, TValue tv_d1,
- TValue tv_n2, TValue tv_d2, TValue tv_res)
+ TValue tv_n2, TValue tv_d2, TValue tv_res)
{
Bigint *n1 = tv2bigint(tv_n1);
Bigint *d1 = tv2bigint(tv_d1);
@@ -575,51 +575,51 @@ static void simplest(klisp_State *K, TValue tv_n1, TValue tv_d1,
Bigint *r2 = tv2bigint(tv_r2);
while(true) {
- UNUSED(mp_int_div(K, n1, d1, q1, r1));
- UNUSED(mp_int_div(K, n2, d2, q2, r2));
-
- if (mp_int_compare_zero(r1) == 0) {
- /* res = q1 / 1 */
- mp_rat_zero(K, res);
- mp_rat_add_int(K, res, q1, res);
- break;
- } else if (mp_int_compare(q1, q2) != 0) {
- /* res = (q1 + 1) / 1 */
- mp_rat_zero(K, res);
- mp_int_add_value(K, q1, 1, q1);
- mp_rat_add_int(K, res, q1, res);
- break;
- } else {
- /* simulate a recursive call */
- TValue saved_q1 = kbigint_make_simple(K);
- krooted_tvs_push(K, saved_q1);
- UNUSED(mp_int_copy(K, q1, tv2bigint(saved_q1)));
- ks_spush(K, saved_q1);
- krooted_tvs_pop(K);
-
- UNUSED(mp_int_copy(K, d2, n1));
- UNUSED(mp_int_copy(K, d1, n2));
- UNUSED(mp_int_copy(K, r2, d1));
- UNUSED(mp_int_copy(K, r1, d2));
- } /* fall through */
+ UNUSED(mp_int_div(K, n1, d1, q1, r1));
+ UNUSED(mp_int_div(K, n2, d2, q2, r2));
+
+ if (mp_int_compare_zero(r1) == 0) {
+ /* res = q1 / 1 */
+ mp_rat_zero(K, res);
+ mp_rat_add_int(K, res, q1, res);
+ break;
+ } else if (mp_int_compare(q1, q2) != 0) {
+ /* res = (q1 + 1) / 1 */
+ mp_rat_zero(K, res);
+ mp_int_add_value(K, q1, 1, q1);
+ mp_rat_add_int(K, res, q1, res);
+ break;
+ } else {
+ /* simulate a recursive call */
+ TValue saved_q1 = kbigint_make_simple(K);
+ krooted_tvs_push(K, saved_q1);
+ UNUSED(mp_int_copy(K, q1, tv2bigint(saved_q1)));
+ ks_spush(K, saved_q1);
+ krooted_tvs_pop(K);
+
+ UNUSED(mp_int_copy(K, d2, n1));
+ UNUSED(mp_int_copy(K, d1, n2));
+ UNUSED(mp_int_copy(K, r2, d1));
+ UNUSED(mp_int_copy(K, r1, d2));
+ } /* fall through */
}
/* now, if there were "recursive" calls, complete them */
while(!ks_sisempty(K)) {
- TValue saved_q1 = ks_sget(K);
- TValue tv_tmp = kbigrat_make_simple(K);
- krooted_tvs_push(K, tv_tmp);
- Bigrat *tmp = tv2bigrat(tv_tmp);
-
- UNUSED(mp_rat_copy(K, res, tmp));
- /* res = (saved_q * n(res)) + d(res)) / n(res) */
- UNUSED(mp_rat_zero(K, res));
- UNUSED(mp_rat_add_int(K, res, tv2bigint(saved_q1), res));
- UNUSED(mp_rat_mul_int(K, res, MP_NUMER_P(tmp), res));
- UNUSED(mp_rat_add_int(K, res, MP_DENOM_P(tmp), res));
- UNUSED(mp_rat_div_int(K, res, MP_NUMER_P(tmp), res));
- krooted_tvs_pop(K); /* tmp */
- ks_sdpop(K); /* saved_q1 */
+ TValue saved_q1 = ks_sget(K);
+ TValue tv_tmp = kbigrat_make_simple(K);
+ krooted_tvs_push(K, tv_tmp);
+ Bigrat *tmp = tv2bigrat(tv_tmp);
+
+ UNUSED(mp_rat_copy(K, res, tmp));
+ /* res = (saved_q * n(res)) + d(res)) / n(res) */
+ UNUSED(mp_rat_zero(K, res));
+ UNUSED(mp_rat_add_int(K, res, tv2bigint(saved_q1), res));
+ UNUSED(mp_rat_mul_int(K, res, MP_NUMER_P(tmp), res));
+ UNUSED(mp_rat_add_int(K, res, MP_DENOM_P(tmp), res));
+ UNUSED(mp_rat_div_int(K, res, MP_NUMER_P(tmp), res));
+ krooted_tvs_pop(K); /* tmp */
+ ks_sdpop(K); /* saved_q1 */
}
krooted_tvs_pop(K); /* q1, r1, q2, r2 */
@@ -640,80 +640,80 @@ TValue kbigrat_simplest_rational(klisp_State *K, TValue tv_n1, TValue tv_n2)
int32_t cmp = mp_rat_compare(K, n1, n2);
if (cmp > 0) { /* n1 > n2, swap */
- TValue temp = tv_n1;
- tv_n1 = tv_n2;
- tv_n2 = temp;
- n1 = tv2bigrat(tv_n1);
- n2 = tv2bigrat(tv_n2);
- /* fall through */
+ TValue temp = tv_n1;
+ tv_n1 = tv_n2;
+ tv_n2 = temp;
+ n1 = tv2bigrat(tv_n1);
+ n2 = tv2bigrat(tv_n2);
+ /* fall through */
} else if (cmp == 0) { /* n1 == n2 */
- krooted_tvs_pop(K);
- return tv_n1;
+ krooted_tvs_pop(K);
+ return tv_n1;
} /* else fall through */
/* we now know that n1 < n2 */
if (mp_rat_compare_zero(n1) > 0) {
- /* 0 > n1 > n2 */
- TValue num1 = kbigint_make_simple(K);
- krooted_tvs_push(K, num1);
- UNUSED(mp_rat_numer(K, n1, tv2bigint(num1)));
+ /* 0 > n1 > n2 */
+ TValue num1 = kbigint_make_simple(K);
+ krooted_tvs_push(K, num1);
+ UNUSED(mp_rat_numer(K, n1, tv2bigint(num1)));
- TValue den1 = kbigint_make_simple(K);
- krooted_tvs_push(K, den1);
- UNUSED(mp_rat_denom(K, n1, tv2bigint(den1)));
+ TValue den1 = kbigint_make_simple(K);
+ krooted_tvs_push(K, den1);
+ UNUSED(mp_rat_denom(K, n1, tv2bigint(den1)));
- TValue num2 = kbigint_make_simple(K);
- krooted_tvs_push(K, num2);
- UNUSED(mp_rat_numer(K, n2, tv2bigint(num2)));
+ TValue num2 = kbigint_make_simple(K);
+ krooted_tvs_push(K, num2);
+ UNUSED(mp_rat_numer(K, n2, tv2bigint(num2)));
- TValue den2 = kbigint_make_simple(K);
- krooted_tvs_push(K, den2);
- UNUSED(mp_rat_denom(K, n2, tv2bigint(den2)));
+ TValue den2 = kbigint_make_simple(K);
+ krooted_tvs_push(K, den2);
+ UNUSED(mp_rat_denom(K, n2, tv2bigint(den2)));
- simplest(K, num1, den1, num2, den2, tv_res);
+ simplest(K, num1, den1, num2, den2, tv_res);
- krooted_tvs_pop(K); /* num1, num2, den1, den2 */
- krooted_tvs_pop(K);
- krooted_tvs_pop(K);
- krooted_tvs_pop(K);
+ krooted_tvs_pop(K); /* num1, num2, den1, den2 */
+ krooted_tvs_pop(K);
+ krooted_tvs_pop(K);
+ krooted_tvs_pop(K);
- krooted_tvs_pop(K); /* tv_res */
- return kbigrat_try_integer(K, tv_res);
+ krooted_tvs_pop(K); /* tv_res */
+ return kbigrat_try_integer(K, tv_res);
} else if (mp_rat_compare_zero(n2) < 0) {
- /* n1 < n2 < 0 */
+ /* n1 < n2 < 0 */
- /* do -(simplest -n2/d2 -n1/d1) */
+ /* do -(simplest -n2/d2 -n1/d1) */
- TValue num1 = kbigint_make_simple(K);
- krooted_tvs_push(K, num1);
- UNUSED(mp_int_neg(K, MP_NUMER_P(n2), tv2bigint(num1)));
+ TValue num1 = kbigint_make_simple(K);
+ krooted_tvs_push(K, num1);
+ UNUSED(mp_int_neg(K, MP_NUMER_P(n2), tv2bigint(num1)));
- TValue den1 = kbigint_make_simple(K);
- krooted_tvs_push(K, den1);
- UNUSED(mp_rat_denom(K, n2, tv2bigint(den1)));
+ TValue den1 = kbigint_make_simple(K);
+ krooted_tvs_push(K, den1);
+ UNUSED(mp_rat_denom(K, n2, tv2bigint(den1)));
- TValue num2 = kbigint_make_simple(K);
- krooted_tvs_push(K, num2);
- UNUSED(mp_int_neg(K, MP_NUMER_P(n1), tv2bigint(num2)));
+ TValue num2 = kbigint_make_simple(K);
+ krooted_tvs_push(K, num2);
+ UNUSED(mp_int_neg(K, MP_NUMER_P(n1), tv2bigint(num2)));
- TValue den2 = kbigint_make_simple(K);
- krooted_tvs_push(K, den2);
- UNUSED(mp_rat_denom(K, n1, tv2bigint(den2)));
+ TValue den2 = kbigint_make_simple(K);
+ krooted_tvs_push(K, den2);
+ UNUSED(mp_rat_denom(K, n1, tv2bigint(den2)));
- simplest(K, num1, den1, num2, den2, tv_res);
- mp_rat_neg(K, res, res);
+ simplest(K, num1, den1, num2, den2, tv_res);
+ mp_rat_neg(K, res, res);
- krooted_tvs_pop(K); /* num1, num2, den1, den2 */
- krooted_tvs_pop(K);
- krooted_tvs_pop(K);
- krooted_tvs_pop(K);
+ krooted_tvs_pop(K); /* num1, num2, den1, den2 */
+ krooted_tvs_pop(K);
+ krooted_tvs_pop(K);
+ krooted_tvs_pop(K);
- krooted_tvs_pop(K); /* tv_res */
- return kbigrat_try_integer(K, tv_res);
+ krooted_tvs_pop(K); /* tv_res */
+ return kbigrat_try_integer(K, tv_res);
} else {
- /* n1 < 0 < n2 */
- krooted_tvs_pop(K);
- return i2tv(0);
+ /* n1 < 0 < n2 */
+ krooted_tvs_pop(K);
+ return i2tv(0);
}
}
diff --git a/src/krational.h b/src/krational.h
@@ -24,16 +24,16 @@ inline TValue kbigrat_try_integer(klisp_State *K, TValue n)
Bigrat *b = tv2bigrat(n);
if (!mp_rat_is_integer(b))
- return n;
+ return n;
/* sadly we have to repeat the code from try_fixint here... */
Bigint *i = MP_NUMER_P(b);
if (MP_USED(i) == 1) {
- int64_t digit = (int64_t) *(MP_DIGITS(i));
- if (MP_SIGN(i) == MP_NEG) digit = -digit;
- if (kfit_int32_t(digit))
- return i2tv((int32_t) digit);
- /* else fall through */
+ int64_t digit = (int64_t) *(MP_DIGITS(i));
+ if (MP_SIGN(i) == MP_NEG) digit = -digit;
+ if (kfit_int32_t(digit))
+ return i2tv((int32_t) digit);
+ /* else fall through */
}
/* should alloc a bigint */
/* GC: n may not be rooted */
@@ -45,7 +45,7 @@ inline TValue kbigrat_try_integer(klisp_State *K, TValue n)
/* used in reading and for res & temps in operations */
TValue kbigrat_new(klisp_State *K, bool sign, uint32_t num,
- uint32_t den);
+ uint32_t den);
/* used in write to destructively get the digits */
TValue kbigrat_copy(klisp_State *K, TValue src);
@@ -56,48 +56,48 @@ TValue kbigrat_copy(klisp_State *K, TValue src);
/* Create a stack allocated bigrat from a bigint,
useful for mixed operations, relatively light weight compared
to creating it in the heap and burdening the gc */
-#define kbind_bigrat_fixint(name, fixint) \
- int32_t (KUNIQUE_NAME(i)) = ivalue(fixint); \
- Bigrat KUNIQUE_NAME(bigrat_i); \
+#define kbind_bigrat_fixint(name, fixint) \
+ int32_t (KUNIQUE_NAME(i)) = ivalue(fixint); \
+ Bigrat KUNIQUE_NAME(bigrat_i); \
/* can't use unique_name bigrat because it conflicts */ \
- /* numer is 1 */ \
- (KUNIQUE_NAME(bigrat_i)).num.single = ({ \
- int64_t temp = (KUNIQUE_NAME(i)); \
- (uint32_t) ((temp < 0)? -temp : temp); \
- }); \
- (KUNIQUE_NAME(bigrat_i)).num.digits = \
- &((KUNIQUE_NAME(bigrat_i)).num.single); \
- (KUNIQUE_NAME(bigrat_i)).num.alloc = 1; \
- (KUNIQUE_NAME(bigrat_i)).num.used = 1; \
- (KUNIQUE_NAME(bigrat_i)).num.sign = (KUNIQUE_NAME(i)) < 0? \
- MP_NEG : MP_ZPOS; \
- /* denom is 1 */ \
- (KUNIQUE_NAME(bigrat_i)).den.single = 1; \
- (KUNIQUE_NAME(bigrat_i)).den.digits = \
- &((KUNIQUE_NAME(bigrat_i)).den.single); \
- (KUNIQUE_NAME(bigrat_i)).den.alloc = 1; \
- (KUNIQUE_NAME(bigrat_i)).den.used = 1; \
- (KUNIQUE_NAME(bigrat_i)).den.sign = MP_ZPOS; \
- \
+ /* numer is 1 */ \
+ (KUNIQUE_NAME(bigrat_i)).num.single = ({ \
+ int64_t temp = (KUNIQUE_NAME(i)); \
+ (uint32_t) ((temp < 0)? -temp : temp); \
+ }); \
+ (KUNIQUE_NAME(bigrat_i)).num.digits = \
+ &((KUNIQUE_NAME(bigrat_i)).num.single); \
+ (KUNIQUE_NAME(bigrat_i)).num.alloc = 1; \
+ (KUNIQUE_NAME(bigrat_i)).num.used = 1; \
+ (KUNIQUE_NAME(bigrat_i)).num.sign = (KUNIQUE_NAME(i)) < 0? \
+ MP_NEG : MP_ZPOS; \
+ /* denom is 1 */ \
+ (KUNIQUE_NAME(bigrat_i)).den.single = 1; \
+ (KUNIQUE_NAME(bigrat_i)).den.digits = \
+ &((KUNIQUE_NAME(bigrat_i)).den.single); \
+ (KUNIQUE_NAME(bigrat_i)).den.alloc = 1; \
+ (KUNIQUE_NAME(bigrat_i)).den.used = 1; \
+ (KUNIQUE_NAME(bigrat_i)).den.sign = MP_ZPOS; \
+ \
Bigrat *name = &(KUNIQUE_NAME(bigrat_i))
-#define kbind_bigrat_bigint(name, bigint) \
- Bigint *KUNIQUE_NAME(bi) = tv2bigint(bigint); \
- Bigrat KUNIQUE_NAME(bigrat); \
- /* numer is bigint */ \
- (KUNIQUE_NAME(bigrat)).num.single = (KUNIQUE_NAME(bi))->single; \
- (KUNIQUE_NAME(bigrat)).num.digits = (KUNIQUE_NAME(bi))->digits; \
- (KUNIQUE_NAME(bigrat)).num.alloc = (KUNIQUE_NAME(bi))->alloc; \
- (KUNIQUE_NAME(bigrat)).num.used = (KUNIQUE_NAME(bi))->used; \
- (KUNIQUE_NAME(bigrat)).num.sign = (KUNIQUE_NAME(bi))->sign; \
- /* denom is 1 */ \
- (KUNIQUE_NAME(bigrat)).den.single = 1; \
- (KUNIQUE_NAME(bigrat)).den.digits = \
- &((KUNIQUE_NAME(bigrat)).den.single); \
- (KUNIQUE_NAME(bigrat)).den.alloc = 1; \
- (KUNIQUE_NAME(bigrat)).den.used = 1; \
- (KUNIQUE_NAME(bigrat)).den.sign = MP_ZPOS; \
- Bigrat *name = &(KUNIQUE_NAME(bigrat))
+#define kbind_bigrat_bigint(name, bigint) \
+ Bigint *KUNIQUE_NAME(bi) = tv2bigint(bigint); \
+ Bigrat KUNIQUE_NAME(bigrat); \
+ /* numer is bigint */ \
+ (KUNIQUE_NAME(bigrat)).num.single = (KUNIQUE_NAME(bi))->single; \
+ (KUNIQUE_NAME(bigrat)).num.digits = (KUNIQUE_NAME(bi))->digits; \
+ (KUNIQUE_NAME(bigrat)).num.alloc = (KUNIQUE_NAME(bi))->alloc; \
+ (KUNIQUE_NAME(bigrat)).num.used = (KUNIQUE_NAME(bi))->used; \
+ (KUNIQUE_NAME(bigrat)).num.sign = (KUNIQUE_NAME(bi))->sign; \
+ /* denom is 1 */ \
+ (KUNIQUE_NAME(bigrat)).den.single = 1; \
+ (KUNIQUE_NAME(bigrat)).den.digits = \
+ &((KUNIQUE_NAME(bigrat)).den.single); \
+ (KUNIQUE_NAME(bigrat)).den.alloc = 1; \
+ (KUNIQUE_NAME(bigrat)).den.used = 1; \
+ (KUNIQUE_NAME(bigrat)).den.sign = MP_ZPOS; \
+ Bigrat *name = &(KUNIQUE_NAME(bigrat))
/* XXX: Now that I think about it this (and kensure_bigint) could be more
cleanly implemented as a function that takes a pointer... (derp derp) */
@@ -105,22 +105,22 @@ TValue kbigrat_copy(klisp_State *K, TValue src);
/* This can be used prior to calling a bigrat functions
to automatically convert fixints & bigints to bigrats.
NOTE: calls to this macro should go in different lines!
- and on different lines to calls to kensure_bigint */
-#define kensure_bigrat(n) \
- /* must use goto, no block should be entered before calling \
- kbind_bigrat */ \
- if (ttisbigrat(n)) \
- goto KUNIQUE_NAME(bigrat_exit_lbl); \
- if (ttisbigint(n)) \
- goto KUNIQUE_NAME(bigrat_bigint_lbl); \
- /* else ttisfixint(n) */ \
- kbind_bigrat_fixint(KUNIQUE_NAME(brat_i), (n)); \
- (n) = gc2bigrat(KUNIQUE_NAME(brat_i)); \
- goto KUNIQUE_NAME(bigrat_exit_lbl); \
-KUNIQUE_NAME(bigrat_bigint_lbl): \
- ; /* gcc asks for a statement (not a decl) after label */ \
- kbind_bigrat_bigint(KUNIQUE_NAME(brat), (n)); \
- (n) = gc2bigrat(KUNIQUE_NAME(brat)); \
+ and on different lines to calls to kensure_bigint */
+#define kensure_bigrat(n) \
+ /* must use goto, no block should be entered before calling \
+ kbind_bigrat */ \
+ if (ttisbigrat(n)) \
+ goto KUNIQUE_NAME(bigrat_exit_lbl); \
+ if (ttisbigint(n)) \
+ goto KUNIQUE_NAME(bigrat_bigint_lbl); \
+ /* else ttisfixint(n) */ \
+ kbind_bigrat_fixint(KUNIQUE_NAME(brat_i), (n)); \
+ (n) = gc2bigrat(KUNIQUE_NAME(brat_i)); \
+ goto KUNIQUE_NAME(bigrat_exit_lbl); \
+KUNIQUE_NAME(bigrat_bigint_lbl): \
+ ; /* gcc asks for a statement (not a decl) after label */ \
+ kbind_bigrat_bigint(KUNIQUE_NAME(brat), (n)); \
+ (n) = gc2bigrat(KUNIQUE_NAME(brat)); \
KUNIQUE_NAME(bigrat_exit_lbl):
/*
@@ -129,14 +129,14 @@ KUNIQUE_NAME(bigrat_exit_lbl):
/* this works for bigrats, bigints & fixints, returns true if ok */
/* NOTE: doesn't allow decimal */
bool krational_read(klisp_State *K, char *buf, int32_t base, TValue *out,
- char **end);
+ char **end);
/* NOTE: allow decimal for use after #e */
bool krational_read_decimal(klisp_State *K, char *buf, int32_t base, TValue *out,
- char **end, bool *out_decimalp);
+ char **end, bool *out_decimalp);
int32_t kbigrat_print_size(TValue tv_bigrat, int32_t base);
void kbigrat_print_string(klisp_State *K, TValue tv_bigrat, int32_t base,
- char *buf, int32_t limit);
+ char *buf, int32_t limit);
/* Interface for kgnumbers */
bool kbigrat_eqp(klisp_State *K, TValue bigrat1, TValue bigrat2);
diff --git a/src/kread.c b/src/kread.c
@@ -30,8 +30,8 @@
** with source info of the '(' token.
** ST_MIDDLE_LIST, ST_LAST_ILIST: two elements, first below, second on top:
** - a pair with car: first pair of the list (with source info
-** corrected to car of list) and cdr: source info of the '(' token that
-** started the [i]list.
+** corrected to car of list) and cdr: source info of the '(' token that
+** started the [i]list.
** - another pair, that is the last pair of the list so far.
** ST_PAST_LAST_ILIST: a pair with car: first pair and cdr: source
** info as above (but no pair with last pair).
@@ -41,7 +41,7 @@
** ST_FIRST_EOF_LIST: first pair of the list (with source info, start of file)
** ST_MIDDLE_EOF_LIST: two elements, first below, second on top:
** - a pair with car: first pair of the list (with source info corrected
-** to car of list) and cdr: source info of the start of file.
+** to car of list) and cdr: source info of the start of file.
** - last pair of the list so far.
*/
@@ -63,9 +63,9 @@ typedef enum {
/*
** Error management
*/
-#define kread_error(K, str) \
+#define kread_error(K, str) \
kread_error_g(K, str, false, KINERT)
-#define kread_error_extra(K, str, extra) \
+#define kread_error_extra(K, str, extra) \
kread_error_g(K, str, true, extra)
void kread_error_g(klisp_State *K, char *str, bool extra, TValue extra_value)
@@ -75,17 +75,17 @@ void kread_error_g(klisp_State *K, char *str, bool extra, TValue extra_value)
/* save the source code info on the port */
kport_update_source_info(K->curr_port, K->ktok_source_info.line,
- K->ktok_source_info.col);
+ K->ktok_source_info.col);
/* include the source info (and extra value if present) in the error */
TValue irritants;
if (extra) {
- krooted_tvs_push(K, extra_value); /* will be popped by throw */
- TValue si = ktok_get_source_info(K);
- krooted_tvs_push(K, si); /* will be popped by throw */
- irritants = klist_g(K, false, 2, si, extra_value);
+ krooted_tvs_push(K, extra_value); /* will be popped by throw */
+ TValue si = ktok_get_source_info(K);
+ krooted_tvs_push(K, si); /* will be popped by throw */
+ irritants = klist_g(K, false, 2, si, extra_value);
} else {
- irritants = ktok_get_source_info(K);
+ irritants = ktok_get_source_info(K);
}
krooted_tvs_push(K, irritants); /* will be popped by throw */
klispE_throw_with_irritants(K, str, irritants);
@@ -103,10 +103,10 @@ TValue try_shared_ref(klisp_State *K, TValue ref_token)
int32_t ref_num = ivalue(kcdr(ref_token));
TValue tail = K->shared_dict;
while (!ttisnil(tail)) {
- TValue head = kcar(tail);
- if (ref_num == ivalue(kcar(head)))
- return kcdr(head);
- tail = kcdr(tail);
+ TValue head = kcar(tail);
+ if (ref_num == ivalue(kcar(head)))
+ return kcdr(head);
+ tail = kcdr(tail);
}
kread_error_extra(K, "undefined shared ref found", i2tv(ref_num));
@@ -121,13 +121,13 @@ void try_shared_def(klisp_State *K, TValue def_token, TValue value)
int32_t ref_num = ivalue(kcdr(def_token));
TValue tail = K->shared_dict;
while (!ttisnil(tail)) {
- TValue head = kcar(tail);
- if (ref_num == ivalue(kcar(head))) {
- kread_error_extra(K, "duplicate shared def found", i2tv(ref_num));
- /* avoid warning */
- return;
- }
- tail = kcdr(tail);
+ TValue head = kcar(tail);
+ if (ref_num == ivalue(kcar(head))) {
+ kread_error_extra(K, "duplicate shared def found", i2tv(ref_num));
+ /* avoid warning */
+ return;
+ }
+ tail = kcdr(tail);
}
TValue new_tok = kcons(K, kcdr(def_token), value);
@@ -145,12 +145,12 @@ void change_shared_def(klisp_State *K, TValue def_token, TValue value)
int32_t ref_num = ivalue(kcdr(def_token));
TValue tail = K->shared_dict;
while (!ttisnil(tail)) {
- TValue head = kcar(tail);
- if (ref_num == ivalue(kcar(head))) {
- kset_cdr(head, value);
- return;
- }
- tail = kcdr(tail);
+ TValue head = kcar(tail);
+ if (ref_num == ivalue(kcar(head))) {
+ kset_cdr(head, value);
+ return;
+ }
+ tail = kcdr(tail);
}
klisp_assert(0); /* shouldn't happen */
return;
@@ -164,18 +164,18 @@ void remove_shared_def(klisp_State *K, TValue def_token)
TValue tail = K->shared_dict;
TValue last_pair = KNIL;
while (!ttisnil(tail)) {
- TValue head = kcar(tail);
- if (ref_num == ivalue(kcar(head))) {
- if (ttisnil(last_pair)) {
- /* this is the first value */
- K->shared_dict = kcdr(tail);
- } else {
- kset_cdr(last_pair, kcdr(tail));
- }
- return;
- }
- last_pair = tail;
- tail = kcdr(tail);
+ TValue head = kcar(tail);
+ if (ref_num == ivalue(kcar(head))) {
+ if (ttisnil(last_pair)) {
+ /* this is the first value */
+ K->shared_dict = kcdr(tail);
+ } else {
+ kset_cdr(last_pair, kcdr(tail));
+ }
+ return;
+ }
+ last_pair = tail;
+ tail = kcdr(tail);
}
klisp_assert(0); /* shouldn't happen */
return;
@@ -202,23 +202,23 @@ TValue kread_fsm(klisp_State *K, bool listp)
push_state(K, ST_READ);
if (listp) { /* read a list of values */
- /* create the first pair */
- TValue np = kcons_g(K, K->read_mconsp, KINERT, KNIL);
- krooted_tvs_push(K, np);
- /*
- ** NOTE: the source info of the start of file is temporarily
- ** saved in np (later it will be replace by the source info
- ** of the car of the list)
- */
- TValue si = ktok_get_source_info(K);
- krooted_tvs_push(K, si);
+ /* create the first pair */
+ TValue np = kcons_g(K, K->read_mconsp, KINERT, KNIL);
+ krooted_tvs_push(K, np);
+ /*
+ ** NOTE: the source info of the start of file is temporarily
+ ** saved in np (later it will be replace by the source info
+ ** of the car of the list)
+ */
+ TValue si = ktok_get_source_info(K);
+ krooted_tvs_push(K, si);
#if KTRACK_SI
- kset_source_info(K, np, si);
+ kset_source_info(K, np, si);
#endif
- krooted_tvs_pop(K);
- push_data(K, np);
- krooted_tvs_pop(K);
- push_state(K, ST_FIRST_EOF_LIST);
+ krooted_tvs_pop(K);
+ push_data(K, np);
+ krooted_tvs_pop(K);
+ push_state(K, ST_FIRST_EOF_LIST);
}
/* read next token or process obj */
@@ -240,425 +240,425 @@ TValue kread_fsm(klisp_State *K, bool listp)
krooted_vars_push(K, &sexp_comment_shared);
while (!(get_state(K) == ST_READ && !read_next_token)) {
- if (read_next_token) {
- TValue tok = ktok_read_token(K); /* only root it when necessary */
-
- if (ttispair(tok)) { /* special token */
- switch (chvalue(kcar(tok))) {
- case '(': {
- if (get_state(K) == ST_PAST_LAST_ILIST) {
- kread_error(K, "open paren found after "
- "last element of improper list");
- /* avoid warning */
- return KINERT;
- }
- /* construct the list with the correct type of pair */
- TValue np = kcons_g(K, K->read_mconsp, KINERT, KNIL);
- krooted_tvs_push(K, np);
- /*
- ** NOTE: the source info of the '(' is temporarily saved
- ** in np (later it will be replace by the source info
- ** of the car of the list
- */
- TValue si = ktok_get_source_info(K);
- krooted_tvs_push(K, si);
- #if KTRACK_SI
- kset_source_info(K, np, si);
- #endif
- krooted_tvs_pop(K);
- /* update the shared def to point to the new list */
- /* NOTE: this is necessary for self referencing lists */
- /* NOTE: the shared def was already checked for errors */
- if (get_state(K) == ST_SHARED_DEF) {
- /* take the state out of the way */
- pop_state(K);
- change_shared_def(K, kcar(get_data(K)), np);
- push_state(K, ST_SHARED_DEF);
- }
+ if (read_next_token) {
+ TValue tok = ktok_read_token(K); /* only root it when necessary */
+
+ if (ttispair(tok)) { /* special token */
+ switch (chvalue(kcar(tok))) {
+ case '(': {
+ if (get_state(K) == ST_PAST_LAST_ILIST) {
+ kread_error(K, "open paren found after "
+ "last element of improper list");
+ /* avoid warning */
+ return KINERT;
+ }
+ /* construct the list with the correct type of pair */
+ TValue np = kcons_g(K, K->read_mconsp, KINERT, KNIL);
+ krooted_tvs_push(K, np);
+ /*
+ ** NOTE: the source info of the '(' is temporarily saved
+ ** in np (later it will be replace by the source info
+ ** of the car of the list
+ */
+ TValue si = ktok_get_source_info(K);
+ krooted_tvs_push(K, si);
+#if KTRACK_SI
+ kset_source_info(K, np, si);
+#endif
+ krooted_tvs_pop(K);
+ /* update the shared def to point to the new list */
+ /* NOTE: this is necessary for self referencing lists */
+ /* NOTE: the shared def was already checked for errors */
+ if (get_state(K) == ST_SHARED_DEF) {
+ /* take the state out of the way */
+ pop_state(K);
+ change_shared_def(K, kcar(get_data(K)), np);
+ push_state(K, ST_SHARED_DEF);
+ }
- /* start reading elements of the new list */
- push_data(K, np);
- push_state(K, ST_FIRST_LIST);
- read_next_token = true;
-
- krooted_tvs_pop(K);
- break;
- }
- case ')': {
- switch(get_state(K)) {
- case ST_FIRST_LIST: { /* empty list */
- /*
- ** Discard the pair in sdata but
- ** retain the source info
- ** Return () for processing
- */
- pop_state(K);
- TValue fp_with_old_si = get_data(K);
- pop_data(K);
-
- obj = KNIL;
- #if KTRACK_SI
- obj_si = kget_source_info(K, fp_with_old_si);
- #else
- UNUSED(fp_with_old_si);
- obj_si = KNIL;
- #endif
- read_next_token = false;
- break;
- }
- case ST_MIDDLE_LIST: /* end of list */
- case ST_PAST_LAST_ILIST: { /* end of ilist */
- pop_state(K);
- /* discard info on last pair */
- pop_data(K);
- pop_state(K);
- TValue fp_old_si = get_data(K);
- pop_data(K);
- /* list read ok, process it in next iteration */
- obj = kcar(fp_old_si);
- obj_si = kcdr(fp_old_si);
- read_next_token = false;
- break;
- }
- case ST_LAST_ILIST:
- kread_error(K, "missing last element in "
- "improper list");
- /* avoid warning */
- return KINERT;
- case ST_SHARED_DEF:
- kread_error(K, "unmatched closing paren found "
- "in shared def");
- /* avoid warning */
- return KINERT;
- case ST_SEXP_COMMENT:
- kread_error_extra(K, "unmatched closing paren found in "
- "sexp comment", last_sexp_comment_si);
- /* avoid warning */
- return KINERT;
- case ST_READ:
- case ST_FIRST_EOF_LIST:
- case ST_MIDDLE_EOF_LIST:
- kread_error(K, "unmatched closing paren found");
- /* avoid warning */
- return KINERT;
- default:
- /* shouldn't happen */
- kread_error(K, "Unknown read state in )");
- /* avoid warning */
- return KINERT;
- }
- break;
- }
- case '.': {
- switch(get_state(K)) {
- case (ST_MIDDLE_LIST):
- /* tok ok, read next obj for cdr of ilist */
- pop_state(K);
- push_state(K, ST_LAST_ILIST);
- read_next_token = true;
- break;
- case ST_FIRST_LIST:
- kread_error(K, "missing first element of "
- "improper list");
- /* avoid warning */
- return KINERT;
- case ST_LAST_ILIST:
- case ST_PAST_LAST_ILIST:
- kread_error(K, "double dot in improper list");
- /* avoid warning */
- return KINERT;
- case ST_SHARED_DEF:
- kread_error(K, "dot found in shared def");
- /* avoid warning */
- return KINERT;
- case ST_SEXP_COMMENT:
- kread_error_extra(K, "dot found outside list in sexp "
- "comment", last_sexp_comment_si);
- /* avoid warning */
- return KINERT;
- case ST_READ:
- case ST_FIRST_EOF_LIST:
- case ST_MIDDLE_EOF_LIST:
- kread_error(K, "dot found outside list");
- /* avoid warning */
- return KINERT;
- default:
- /* shouldn't happen */
- kread_error(K, "Unknown read state in .");
- /* avoid warning */
- return KINERT;
- }
- break;
- }
- case '=': { /* srfi-38 shared def */
- switch (get_state(K)) {
- case ST_SHARED_DEF:
- kread_error(K, "shared def found in "
- "shared def");
- /* avoid warning */
- return KINERT;
- case ST_PAST_LAST_ILIST:
- kread_error(K, "shared def found after "
- "last element of improper list");
- /* avoid warning */
- return KINERT;
- default: {
- krooted_tvs_push(K, tok);
- try_shared_def(K, tok, KNIL);
- /* token ok */
- /* save the token for later undefining */
- if (sexp_comments > 0) {
- kset_car(sexp_comment_shared,
- kcons(K, tok, kcar(sexp_comment_shared)));
- }
- /* read defined object */
- /* NOTE: save the source info to return it
- after the defined object is read */
- TValue si = ktok_get_source_info(K);
- krooted_tvs_push(K, si);
- push_data(K, kcons(K, tok, si));
- krooted_tvs_pop(K);
- krooted_tvs_pop(K);
- push_state(K, ST_SHARED_DEF);
- read_next_token = true;
- }
- }
- break;
- }
- case '#': { /* srfi-38 shared ref */
- switch(get_state(K)) {
- case ST_SHARED_DEF:
- kread_error(K, "shared ref found in "
- "shared def");
- /* avoid warning */
- return KINERT;
- case ST_PAST_LAST_ILIST:
- kread_error(K, "shared ref found after "
- "last element of improper list");
- /* avoid warning */
- return KINERT;
- default: {
- TValue res = try_shared_ref(K, tok);
- /* ref ok, process it in next iteration */
- obj = res;
- /* NOTE: use source info of ref token */
- obj_si = ktok_get_source_info(K);
- read_next_token = false;
- }
- }
- break;
- }
- case ';': { /* sexp comment */
- klisp_assert(sexp_comments < 1000);
- ++sexp_comments;
- sexp_comment_shared =
- kcons(K, KNIL, sexp_comment_shared);
- push_data(K, last_sexp_comment_si);
- push_state(K, ST_SEXP_COMMENT);
- last_sexp_comment_si = ktok_get_source_info(K);
- read_next_token = true;
- break;
- }
- default:
- /* shouldn't happen */
- kread_error(K, "unknown special token");
- /* avoid warning */
- return KINERT;
- }
- } else if (ttiseof(tok)) {
- switch (get_state(K)) {
- case ST_SEXP_COMMENT:
- kread_error_extra(K, "EOF found while reading sexp "
- " comment", last_sexp_comment_si);
- /* avoid warning */
- return KINERT;
- case ST_FIRST_EOF_LIST: {
- pop_state(K);
- TValue fp_with_old_si = get_data(K);
- pop_data(K);
- obj = KNIL;
- #if KTRACK_SI
- obj_si = kget_source_info(K, fp_with_old_si);
- #else
- UNUSED(fp_with_old_si);
- obj_si = KNIL;
- #endif
- read_next_token = false;
- break;
- }
- case ST_MIDDLE_EOF_LIST: {
- pop_state(K);
- /* discard info on last pair */
- pop_data(K);
- pop_state(K);
- TValue fp_old_si = get_data(K);
- pop_data(K);
- /* list read ok, process it in next iteration */
- obj = kcar(fp_old_si);
- obj_si = kcdr(fp_old_si);
- read_next_token = false;
- break;
- }
- case ST_READ:
- obj = tok;
- obj_si = ktok_get_source_info(K);
- /* will exit in next loop */
- read_next_token = false;
- break;
- case ST_FIRST_LIST:
- case ST_MIDDLE_LIST:
- kread_error(K, "EOF found while reading list");
- /* avoid warning */
- return KINERT;
- case ST_LAST_ILIST:
- case ST_PAST_LAST_ILIST:
- kread_error(K, "EOF found while reading "
- "improper list");
- /* avoid warning */
- return KINERT;
- case ST_SHARED_DEF:
- kread_error(K, "EOF found in shared def");
- /* avoid warning */
- return KINERT;
- default:
- /* shouldn't happen */
- kread_error(K, "unknown read state in EOF");
- /* avoid warning */
- return KINERT;
- }
- } else { /* this can only be a complete token */
- if (get_state(K) == ST_PAST_LAST_ILIST) {
- kread_error(K, "Non paren found after last "
- "element of improper list");
- /* avoid warning */
- return KINERT;
- } else {
- /* token ok, process it in next iteration */
- obj = tok;
- obj_si = ktok_get_source_info(K);
- read_next_token = false;
- }
- }
- } else { /* read_next_token == false */
- /* process the object just read */
- switch(get_state(K)) {
- case ST_FIRST_EOF_LIST:
- case ST_FIRST_LIST: {
- state_t state = get_state(K);
- /* get the state out of the way */
- pop_state(K);
- TValue fp = get_data(K);
- /* replace source info in fp with the saved one */
- /* NOTE: the old one will be returned when list is complete */
- /* GC: the way things are done here fp is rooted at all
- times */
- #if KTRACK_SI
- TValue fp_old_si = kget_source_info(K, fp);
- #else
- TValue fp_old_si = KNIL;
- #endif
- krooted_tvs_push(K, fp);
- krooted_tvs_push(K, fp_old_si);
- #if KTRACK_SI
- kset_source_info(K, fp, obj_si);
- #endif
- kset_car_unsafe(K, fp, obj);
+ /* start reading elements of the new list */
+ push_data(K, np);
+ push_state(K, ST_FIRST_LIST);
+ read_next_token = true;
+
+ krooted_tvs_pop(K);
+ break;
+ }
+ case ')': {
+ switch(get_state(K)) {
+ case ST_FIRST_LIST: { /* empty list */
+ /*
+ ** Discard the pair in sdata but
+ ** retain the source info
+ ** Return () for processing
+ */
+ pop_state(K);
+ TValue fp_with_old_si = get_data(K);
+ pop_data(K);
+
+ obj = KNIL;
+#if KTRACK_SI
+ obj_si = kget_source_info(K, fp_with_old_si);
+#else
+ UNUSED(fp_with_old_si);
+ obj_si = KNIL;
+#endif
+ read_next_token = false;
+ break;
+ }
+ case ST_MIDDLE_LIST: /* end of list */
+ case ST_PAST_LAST_ILIST: { /* end of ilist */
+ pop_state(K);
+ /* discard info on last pair */
+ pop_data(K);
+ pop_state(K);
+ TValue fp_old_si = get_data(K);
+ pop_data(K);
+ /* list read ok, process it in next iteration */
+ obj = kcar(fp_old_si);
+ obj_si = kcdr(fp_old_si);
+ read_next_token = false;
+ break;
+ }
+ case ST_LAST_ILIST:
+ kread_error(K, "missing last element in "
+ "improper list");
+ /* avoid warning */
+ return KINERT;
+ case ST_SHARED_DEF:
+ kread_error(K, "unmatched closing paren found "
+ "in shared def");
+ /* avoid warning */
+ return KINERT;
+ case ST_SEXP_COMMENT:
+ kread_error_extra(K, "unmatched closing paren found in "
+ "sexp comment", last_sexp_comment_si);
+ /* avoid warning */
+ return KINERT;
+ case ST_READ:
+ case ST_FIRST_EOF_LIST:
+ case ST_MIDDLE_EOF_LIST:
+ kread_error(K, "unmatched closing paren found");
+ /* avoid warning */
+ return KINERT;
+ default:
+ /* shouldn't happen */
+ kread_error(K, "Unknown read state in )");
+ /* avoid warning */
+ return KINERT;
+ }
+ break;
+ }
+ case '.': {
+ switch(get_state(K)) {
+ case (ST_MIDDLE_LIST):
+ /* tok ok, read next obj for cdr of ilist */
+ pop_state(K);
+ push_state(K, ST_LAST_ILIST);
+ read_next_token = true;
+ break;
+ case ST_FIRST_LIST:
+ kread_error(K, "missing first element of "
+ "improper list");
+ /* avoid warning */
+ return KINERT;
+ case ST_LAST_ILIST:
+ case ST_PAST_LAST_ILIST:
+ kread_error(K, "double dot in improper list");
+ /* avoid warning */
+ return KINERT;
+ case ST_SHARED_DEF:
+ kread_error(K, "dot found in shared def");
+ /* avoid warning */
+ return KINERT;
+ case ST_SEXP_COMMENT:
+ kread_error_extra(K, "dot found outside list in sexp "
+ "comment", last_sexp_comment_si);
+ /* avoid warning */
+ return KINERT;
+ case ST_READ:
+ case ST_FIRST_EOF_LIST:
+ case ST_MIDDLE_EOF_LIST:
+ kread_error(K, "dot found outside list");
+ /* avoid warning */
+ return KINERT;
+ default:
+ /* shouldn't happen */
+ kread_error(K, "Unknown read state in .");
+ /* avoid warning */
+ return KINERT;
+ }
+ break;
+ }
+ case '=': { /* srfi-38 shared def */
+ switch (get_state(K)) {
+ case ST_SHARED_DEF:
+ kread_error(K, "shared def found in "
+ "shared def");
+ /* avoid warning */
+ return KINERT;
+ case ST_PAST_LAST_ILIST:
+ kread_error(K, "shared def found after "
+ "last element of improper list");
+ /* avoid warning */
+ return KINERT;
+ default: {
+ krooted_tvs_push(K, tok);
+ try_shared_def(K, tok, KNIL);
+ /* token ok */
+ /* save the token for later undefining */
+ if (sexp_comments > 0) {
+ kset_car(sexp_comment_shared,
+ kcons(K, tok, kcar(sexp_comment_shared)));
+ }
+ /* read defined object */
+ /* NOTE: save the source info to return it
+ after the defined object is read */
+ TValue si = ktok_get_source_info(K);
+ krooted_tvs_push(K, si);
+ push_data(K, kcons(K, tok, si));
+ krooted_tvs_pop(K);
+ krooted_tvs_pop(K);
+ push_state(K, ST_SHARED_DEF);
+ read_next_token = true;
+ }
+ }
+ break;
+ }
+ case '#': { /* srfi-38 shared ref */
+ switch(get_state(K)) {
+ case ST_SHARED_DEF:
+ kread_error(K, "shared ref found in "
+ "shared def");
+ /* avoid warning */
+ return KINERT;
+ case ST_PAST_LAST_ILIST:
+ kread_error(K, "shared ref found after "
+ "last element of improper list");
+ /* avoid warning */
+ return KINERT;
+ default: {
+ TValue res = try_shared_ref(K, tok);
+ /* ref ok, process it in next iteration */
+ obj = res;
+ /* NOTE: use source info of ref token */
+ obj_si = ktok_get_source_info(K);
+ read_next_token = false;
+ }
+ }
+ break;
+ }
+ case ';': { /* sexp comment */
+ klisp_assert(sexp_comments < 1000);
+ ++sexp_comments;
+ sexp_comment_shared =
+ kcons(K, KNIL, sexp_comment_shared);
+ push_data(K, last_sexp_comment_si);
+ push_state(K, ST_SEXP_COMMENT);
+ last_sexp_comment_si = ktok_get_source_info(K);
+ read_next_token = true;
+ break;
+ }
+ default:
+ /* shouldn't happen */
+ kread_error(K, "unknown special token");
+ /* avoid warning */
+ return KINERT;
+ }
+ } else if (ttiseof(tok)) {
+ switch (get_state(K)) {
+ case ST_SEXP_COMMENT:
+ kread_error_extra(K, "EOF found while reading sexp "
+ " comment", last_sexp_comment_si);
+ /* avoid warning */
+ return KINERT;
+ case ST_FIRST_EOF_LIST: {
+ pop_state(K);
+ TValue fp_with_old_si = get_data(K);
+ pop_data(K);
+ obj = KNIL;
+#if KTRACK_SI
+ obj_si = kget_source_info(K, fp_with_old_si);
+#else
+ UNUSED(fp_with_old_si);
+ obj_si = KNIL;
+#endif
+ read_next_token = false;
+ break;
+ }
+ case ST_MIDDLE_EOF_LIST: {
+ pop_state(K);
+ /* discard info on last pair */
+ pop_data(K);
+ pop_state(K);
+ TValue fp_old_si = get_data(K);
+ pop_data(K);
+ /* list read ok, process it in next iteration */
+ obj = kcar(fp_old_si);
+ obj_si = kcdr(fp_old_si);
+ read_next_token = false;
+ break;
+ }
+ case ST_READ:
+ obj = tok;
+ obj_si = ktok_get_source_info(K);
+ /* will exit in next loop */
+ read_next_token = false;
+ break;
+ case ST_FIRST_LIST:
+ case ST_MIDDLE_LIST:
+ kread_error(K, "EOF found while reading list");
+ /* avoid warning */
+ return KINERT;
+ case ST_LAST_ILIST:
+ case ST_PAST_LAST_ILIST:
+ kread_error(K, "EOF found while reading "
+ "improper list");
+ /* avoid warning */
+ return KINERT;
+ case ST_SHARED_DEF:
+ kread_error(K, "EOF found in shared def");
+ /* avoid warning */
+ return KINERT;
+ default:
+ /* shouldn't happen */
+ kread_error(K, "unknown read state in EOF");
+ /* avoid warning */
+ return KINERT;
+ }
+ } else { /* this can only be a complete token */
+ if (get_state(K) == ST_PAST_LAST_ILIST) {
+ kread_error(K, "Non paren found after last "
+ "element of improper list");
+ /* avoid warning */
+ return KINERT;
+ } else {
+ /* token ok, process it in next iteration */
+ obj = tok;
+ obj_si = ktok_get_source_info(K);
+ read_next_token = false;
+ }
+ }
+ } else { /* read_next_token == false */
+ /* process the object just read */
+ switch(get_state(K)) {
+ case ST_FIRST_EOF_LIST:
+ case ST_FIRST_LIST: {
+ state_t state = get_state(K);
+ /* get the state out of the way */
+ pop_state(K);
+ TValue fp = get_data(K);
+ /* replace source info in fp with the saved one */
+ /* NOTE: the old one will be returned when list is complete */
+ /* GC: the way things are done here fp is rooted at all
+ times */
+#if KTRACK_SI
+ TValue fp_old_si = kget_source_info(K, fp);
+#else
+ TValue fp_old_si = KNIL;
+#endif
+ krooted_tvs_push(K, fp);
+ krooted_tvs_push(K, fp_old_si);
+#if KTRACK_SI
+ kset_source_info(K, fp, obj_si);
+#endif
+ kset_car_unsafe(K, fp, obj);
- /* continue reading objects of list */
- /* save first & last pair of the (still incomplete) list */
- pop_data(K);
- push_data(K, kcons (K, fp, fp_old_si));
- krooted_tvs_pop(K);
- krooted_tvs_pop(K);
- push_state(K, state);
- push_data(K, fp);
- if (state == ST_FIRST_LIST) {
- push_state(K, ST_MIDDLE_LIST);
- } else {
- push_state(K, ST_MIDDLE_EOF_LIST);
- /* shared dict must be cleared after every element
- of an eof list */
- clear_shared_dict(K);
- }
- read_next_token = true;
- break;
- }
- case ST_MIDDLE_LIST:
- case ST_MIDDLE_EOF_LIST: {
- state_t state = get_state(K);
- /* get the state out of the way */
- pop_state(K);
- /* construct the list with the correct type of pair */
- /* GC: np is rooted by push_data */
- TValue np = kcons_g(K, K->read_mconsp, obj, KNIL);
- krooted_tvs_push(K, np);
- #if KTRACK_SI
- kset_source_info(K, np, obj_si);
- #endif
- kset_cdr_unsafe(K, get_data(K), np);
- /* replace last pair of the (still incomplete) read next obj */
- pop_data(K);
- push_data(K, np);
- push_state(K, state);
- if (state == ST_MIDDLE_EOF_LIST) {
- /* shared dict must be cleared after every element
- of an eof list */
- clear_shared_dict(K);
- }
- krooted_tvs_pop(K);
- read_next_token = true;
- break;
- }
- case ST_LAST_ILIST:
- /* only change the state, keep the pair data to simplify
- the close paren code (same as for ST_MIDDLE_LIST) */
- pop_state(K);
- kset_cdr_unsafe(K, get_data(K), obj);
- push_state(K, ST_PAST_LAST_ILIST);
- read_next_token = true;
- break;
- case ST_SHARED_DEF: {
- /* shared def completed, continue processing obj */
- pop_state(K);
- TValue def_si = get_data(K);
- pop_data(K);
-
- change_shared_def(K, kcar(def_si), obj);
+ /* continue reading objects of list */
+ /* save first & last pair of the (still incomplete) list */
+ pop_data(K);
+ push_data(K, kcons (K, fp, fp_old_si));
+ krooted_tvs_pop(K);
+ krooted_tvs_pop(K);
+ push_state(K, state);
+ push_data(K, fp);
+ if (state == ST_FIRST_LIST) {
+ push_state(K, ST_MIDDLE_LIST);
+ } else {
+ push_state(K, ST_MIDDLE_EOF_LIST);
+ /* shared dict must be cleared after every element
+ of an eof list */
+ clear_shared_dict(K);
+ }
+ read_next_token = true;
+ break;
+ }
+ case ST_MIDDLE_LIST:
+ case ST_MIDDLE_EOF_LIST: {
+ state_t state = get_state(K);
+ /* get the state out of the way */
+ pop_state(K);
+ /* construct the list with the correct type of pair */
+ /* GC: np is rooted by push_data */
+ TValue np = kcons_g(K, K->read_mconsp, obj, KNIL);
+ krooted_tvs_push(K, np);
+#if KTRACK_SI
+ kset_source_info(K, np, obj_si);
+#endif
+ kset_cdr_unsafe(K, get_data(K), np);
+ /* replace last pair of the (still incomplete) read next obj */
+ pop_data(K);
+ push_data(K, np);
+ push_state(K, state);
+ if (state == ST_MIDDLE_EOF_LIST) {
+ /* shared dict must be cleared after every element
+ of an eof list */
+ clear_shared_dict(K);
+ }
+ krooted_tvs_pop(K);
+ read_next_token = true;
+ break;
+ }
+ case ST_LAST_ILIST:
+ /* only change the state, keep the pair data to simplify
+ the close paren code (same as for ST_MIDDLE_LIST) */
+ pop_state(K);
+ kset_cdr_unsafe(K, get_data(K), obj);
+ push_state(K, ST_PAST_LAST_ILIST);
+ read_next_token = true;
+ break;
+ case ST_SHARED_DEF: {
+ /* shared def completed, continue processing obj */
+ pop_state(K);
+ TValue def_si = get_data(K);
+ pop_data(K);
+
+ change_shared_def(K, kcar(def_si), obj);
- /* obj = obj; */
- /* the source info returned is the one from the shared def */
- obj_si = kcdr(def_si);
- read_next_token = false;
- break;
- }
- case ST_READ:
- /* this shouldn't happen, should've exited the while */
- kread_error(K, "invalid read state (read in while)");
- /* avoid warning */
- return KINERT;
- case ST_SEXP_COMMENT:
- klisp_assert(sexp_comments > 0);
- --sexp_comments;
- /* undefine all shared obj defined in the context
- of this sexp comment */
- while(!ttisnil(kcar(sexp_comment_shared))) {
- TValue first = kcaar(sexp_comment_shared);
- remove_shared_def(K, first);
- kset_car(sexp_comment_shared, kcdar(sexp_comment_shared));
- }
- sexp_comment_shared = kcdr(sexp_comment_shared);
- pop_state(K);
- last_sexp_comment_si = get_data(K);
- pop_data(K);
- read_next_token = true;
- break;
- default:
- /* shouldn't happen */
- kread_error(K, "unknown read state in process obj");
- /* avoid warning */
- return KINERT;
- }
- }
+ /* obj = obj; */
+ /* the source info returned is the one from the shared def */
+ obj_si = kcdr(def_si);
+ read_next_token = false;
+ break;
+ }
+ case ST_READ:
+ /* this shouldn't happen, should've exited the while */
+ kread_error(K, "invalid read state (read in while)");
+ /* avoid warning */
+ return KINERT;
+ case ST_SEXP_COMMENT:
+ klisp_assert(sexp_comments > 0);
+ --sexp_comments;
+ /* undefine all shared obj defined in the context
+ of this sexp comment */
+ while(!ttisnil(kcar(sexp_comment_shared))) {
+ TValue first = kcaar(sexp_comment_shared);
+ remove_shared_def(K, first);
+ kset_car(sexp_comment_shared, kcdar(sexp_comment_shared));
+ }
+ sexp_comment_shared = kcdr(sexp_comment_shared);
+ pop_state(K);
+ last_sexp_comment_si = get_data(K);
+ pop_data(K);
+ read_next_token = true;
+ break;
+ default:
+ /* shouldn't happen */
+ kread_error(K, "unknown read state in process obj");
+ /* avoid warning */
+ return KINERT;
+ }
+ }
}
krooted_vars_pop(K);
@@ -687,18 +687,18 @@ TValue kread(klisp_State *K, bool listp)
TValue kread_from_port_g(klisp_State *K, TValue port, bool mut, bool listp)
{
if (!tv_equal(port, K->curr_port)) {
- K->ktok_seen_eof = false; /* WORKAROUND: for repl problem with eofs */
- K->curr_port = port;
+ K->ktok_seen_eof = false; /* WORKAROUND: for repl problem with eofs */
+ K->curr_port = port;
}
K->read_mconsp = mut;
ktok_set_source_info(K, kport_filename(port),
- kport_line(port), kport_col(port));
+ kport_line(port), kport_col(port));
TValue obj = kread(K, listp);
kport_update_source_info(port, K->ktok_source_info.line,
- K->ktok_source_info.col);
+ K->ktok_source_info.col);
return obj;
}
@@ -732,18 +732,18 @@ TValue kread_peek_char_from_port(klisp_State *K, TValue port, bool peek)
klisp_assert(kport_is_textual(port));
if (!tv_equal(port, K->curr_port)) {
- K->ktok_seen_eof = false; /* WORKAROUND: for repl problem with eofs */
- K->curr_port = port;
+ K->ktok_seen_eof = false; /* WORKAROUND: for repl problem with eofs */
+ K->curr_port = port;
}
int ch;
if (peek) {
- ch = ktok_peekc(K);
+ ch = ktok_peekc(K);
} else {
- ktok_set_source_info(K, kport_filename(port),
- kport_line(port), kport_col(port));
- ch = ktok_getc(K);
- kport_update_source_info(port, K->ktok_source_info.line,
- K->ktok_source_info.col);
+ ktok_set_source_info(K, kport_filename(port),
+ kport_line(port), kport_col(port));
+ ch = ktok_getc(K);
+ kport_update_source_info(port, K->ktok_source_info.line,
+ K->ktok_source_info.col);
}
return ch == EOF? KEOF : ch2tv((char)ch);
}
@@ -756,18 +756,18 @@ TValue kread_peek_u8_from_port(klisp_State *K, TValue port, bool peek)
klisp_assert(kport_is_binary(port));
if (!tv_equal(port, K->curr_port)) {
- K->ktok_seen_eof = false; /* WORKAROUND: for repl problem with eofs */
- K->curr_port = port;
+ K->ktok_seen_eof = false; /* WORKAROUND: for repl problem with eofs */
+ K->curr_port = port;
}
int32_t u8;
if (peek) {
- u8 = ktok_peekc(K);
+ u8 = ktok_peekc(K);
} else {
- ktok_set_source_info(K, kport_filename(port),
- kport_line(port), kport_col(port));
- u8 = ktok_getc(K);
- kport_update_source_info(port, K->ktok_source_info.line,
- K->ktok_source_info.col);
+ ktok_set_source_info(K, kport_filename(port),
+ kport_line(port), kport_col(port));
+ u8 = ktok_getc(K);
+ kport_update_source_info(port, K->ktok_source_info.line,
+ K->ktok_source_info.col);
}
return u8 == EOF? KEOF : i2tv(u8 & 0xff);
}
@@ -780,8 +780,8 @@ TValue kread_line_from_port(klisp_State *K, TValue port)
klisp_assert(kport_is_textual(port));
if (!tv_equal(port, K->curr_port)) {
- K->ktok_seen_eof = false; /* WORKAROUND: for repl problem with eofs */
- K->curr_port = port;
+ K->ktok_seen_eof = false; /* WORKAROUND: for repl problem with eofs */
+ K->curr_port = port;
}
uint32_t size = MINREADLINEBUFFER;
@@ -792,35 +792,35 @@ TValue kread_line_from_port(klisp_State *K, TValue port)
char *buf = kstring_buf(new_str);
ktok_set_source_info(K, kport_filename(port),
- kport_line(port), kport_col(port));
+ kport_line(port), kport_col(port));
bool found_newline = false;
while(true) {
- ch = ktok_getc(K);
- if (ch == EOF) {
- break;
- } else if (ch == '\n') {
- /* adjust string to the right size if necessary */
- if (i < size) {
- new_str = kstring_new_bs(K, kstring_buf(new_str), i);
- }
- found_newline = true;
- break;
- } else {
- if (i == size) {
- size *= 2;
- char *old_buf = kstring_buf(new_str);
- new_str = kstring_new_s(K, size);
- buf = kstring_buf(new_str);
- /* copy the data we have */
- memcpy(buf, old_buf, i);
- buf += i;
- }
- *buf++ = (char) ch;
- ++i;
- }
+ ch = ktok_getc(K);
+ if (ch == EOF) {
+ break;
+ } else if (ch == '\n') {
+ /* adjust string to the right size if necessary */
+ if (i < size) {
+ new_str = kstring_new_bs(K, kstring_buf(new_str), i);
+ }
+ found_newline = true;
+ break;
+ } else {
+ if (i == size) {
+ size *= 2;
+ char *old_buf = kstring_buf(new_str);
+ new_str = kstring_new_s(K, size);
+ buf = kstring_buf(new_str);
+ /* copy the data we have */
+ memcpy(buf, old_buf, i);
+ buf += i;
+ }
+ *buf++ = (char) ch;
+ ++i;
+ }
}
kport_update_source_info(port, K->ktok_source_info.line,
- K->ktok_source_info.col);
+ K->ktok_source_info.col);
krooted_vars_pop(K);
return found_newline? new_str : KEOF;
}
@@ -830,8 +830,8 @@ TValue kread_line_from_port(klisp_State *K, TValue port)
void kread_clear_leading_whitespace_from_port(klisp_State *K, TValue port)
{
if (!tv_equal(port, K->curr_port)) {
- K->ktok_seen_eof = false; /* WORKAROUND: for repl problem with eofs */
- K->curr_port = port;
+ K->ktok_seen_eof = false; /* WORKAROUND: for repl problem with eofs */
+ K->curr_port = port;
}
/* source code info isn't important because it will be reset later */
ktok_ignore_whitespace(K);
diff --git a/src/kreal.c b/src/kreal.c
@@ -29,10 +29,10 @@ double kbigint_to_double(Bigint *bigint)
double accum = 0.0;
/* bigint is in little endian format, but we traverse in
- big endian */
+ big endian */
do {
- --ndigits;
- accum = accum * radix + (double) bigint->digits[ndigits];
+ --ndigits;
+ accum = accum * radix + (double) bigint->digits[ndigits];
} while (ndigits > 0); /* have to compare like this, it's unsigned */
return mp_int_compare_zero(bigint) < 0? -accum : accum;
}
@@ -52,9 +52,9 @@ double kbigrat_to_double(klisp_State *K, Bigrat *bigrat)
int32_t arguments */
UNUSED(mp_int_set_value(K, tv2bigint(int_radix), INT32_MAX));
UNUSED(mp_int_add_value(K, tv2bigint(int_radix), 1,
- tv2bigint(int_radix)));
+ tv2bigint(int_radix)));
UNUSED(mp_int_add(K, tv2bigint(int_radix), tv2bigint(int_radix),
- tv2bigint(int_radix)));
+ tv2bigint(int_radix)));
TValue int_part = kbigint_make_simple(K);
krooted_tvs_push(K, int_part);
@@ -64,24 +64,24 @@ double kbigrat_to_double(klisp_State *K, Bigrat *bigrat)
uint32_t digit = 0;
/* inside there is a check to avoid problem with continuing fractions */
while(mp_rat_compare_zero(rem) > 0) {
- UNUSED(mp_int_div(K, MP_NUMER_P(rem), MP_DENOM_P(rem),
- tv2bigint(int_part), NULL));
-
- double di = kbigint_to_double(tv2bigint(int_part));
- bool was_zero = di == 0.0;
- for (uint32_t i = 0; i < digit; i++) {
- di /= radix;
- }
- /* if last di became 0.0 we will exit next loop,
- this is to avoid problem with continuing fractions */
- if (!was_zero && di == 0.0)
- break;
-
- ++digit;
- accum += di;
+ UNUSED(mp_int_div(K, MP_NUMER_P(rem), MP_DENOM_P(rem),
+ tv2bigint(int_part), NULL));
+
+ double di = kbigint_to_double(tv2bigint(int_part));
+ bool was_zero = di == 0.0;
+ for (uint32_t i = 0; i < digit; i++) {
+ di /= radix;
+ }
+ /* if last di became 0.0 we will exit next loop,
+ this is to avoid problem with continuing fractions */
+ if (!was_zero && di == 0.0)
+ break;
+
+ ++digit;
+ accum += di;
- UNUSED(mp_rat_sub_int(K, rem, tv2bigint(int_part), rem));
- UNUSED(mp_rat_mul_int(K, rem, tv2bigint(int_radix), rem));
+ UNUSED(mp_rat_sub_int(K, rem, tv2bigint(int_part), rem));
+ UNUSED(mp_rat_mul_int(K, rem, tv2bigint(int_radix), rem));
}
krooted_tvs_pop(K); /* int_part */
krooted_tvs_pop(K); /* int_radix */
@@ -98,58 +98,58 @@ TValue kexact_to_inexact(klisp_State *K, TValue n)
switch(ttype(n)) {
case K_TFIXINT:
- /* NOTE: can't over or underflow, and can't give NaN */
- return d2tv((double) ivalue(n));
+ /* NOTE: can't over or underflow, and can't give NaN */
+ return d2tv((double) ivalue(n));
case K_TBIGINT: {
- Bigint *bigint = tv2bigint(n);
- double d = kbigint_to_double(bigint);
- if (strictp && (d == 0.0 || isinf(d) || isnan(d))) {
- /* NOTE: bigints can't be zero */
- char *msg;
- if (isnan(d))
- msg = "unexpected error";
- else if (isinf(d))
- msg = "overflow";
- else
- msg = "undeflow";
- klispE_throw_simple_with_irritants(K, msg, 1, n);
- return KUNDEF;
- } else {
- /* d may be inf, ktag_double will handle it */
- return ktag_double(d);
- }
+ Bigint *bigint = tv2bigint(n);
+ double d = kbigint_to_double(bigint);
+ if (strictp && (d == 0.0 || isinf(d) || isnan(d))) {
+ /* NOTE: bigints can't be zero */
+ char *msg;
+ if (isnan(d))
+ msg = "unexpected error";
+ else if (isinf(d))
+ msg = "overflow";
+ else
+ msg = "undeflow";
+ klispE_throw_simple_with_irritants(K, msg, 1, n);
+ return KUNDEF;
+ } else {
+ /* d may be inf, ktag_double will handle it */
+ return ktag_double(d);
+ }
}
case K_TBIGRAT: {
- Bigrat *bigrat = tv2bigrat(n);
- double d = kbigrat_to_double(K, bigrat);
- /* REFACTOR: this code is the same for bigints... */
- if (strictp && (d == 0.0 || isinf(d) || isnan(d))) {
- /* NOTE: bigrats can't be zero */
- char *msg;
- if (isnan(d))
- msg = "unexpected error";
- else if (isinf(d))
- msg = "overflow";
- else
- msg = "undeflow";
- klispE_throw_simple_with_irritants(K, msg, 1, n);
- return KUNDEF;
- } else {
- /* d may be inf, ktag_double will handle it */
- return ktag_double(d);
- }
+ Bigrat *bigrat = tv2bigrat(n);
+ double d = kbigrat_to_double(K, bigrat);
+ /* REFACTOR: this code is the same for bigints... */
+ if (strictp && (d == 0.0 || isinf(d) || isnan(d))) {
+ /* NOTE: bigrats can't be zero */
+ char *msg;
+ if (isnan(d))
+ msg = "unexpected error";
+ else if (isinf(d))
+ msg = "overflow";
+ else
+ msg = "undeflow";
+ klispE_throw_simple_with_irritants(K, msg, 1, n);
+ return KUNDEF;
+ } else {
+ /* d may be inf, ktag_double will handle it */
+ return ktag_double(d);
+ }
}
case K_TEINF:
- return tv_equal(n, KEPINF)? KIPINF : KIMINF;
- /* all of these are already inexact */
+ return tv_equal(n, KEPINF)? KIPINF : KIMINF;
+ /* all of these are already inexact */
case K_TDOUBLE:
case K_TIINF:
case K_TRWNPV:
case K_TUNDEFINED:
- return n;
+ return n;
default:
- klisp_assert(0);
- return KUNDEF;
+ klisp_assert(0);
+ return KUNDEF;
}
}
@@ -158,7 +158,7 @@ TValue kdouble_to_bigint(klisp_State *K, double d)
{
bool neg = d < 0;
if (neg)
- d = -d;
+ d = -d;
TValue tv_res = kbigint_make_simple(K);
krooted_tvs_push(K, tv_res);
@@ -173,30 +173,30 @@ TValue kdouble_to_bigint(klisp_State *K, double d)
double radix = ((double) UINT32_MAX) + 1.0;
int power = 0;
while(d > 0) {
- double dd = fmod(d, radix);
- d = floor(d / radix);
- /* load in two moves because set_value takes signed ints */
- uint32_t id = (uint32_t) dd;
- int32_t id1 = (int32_t) (id >> 1);
- int32_t id2 = (int32_t) (id - id1);
+ double dd = fmod(d, radix);
+ d = floor(d / radix);
+ /* load in two moves because set_value takes signed ints */
+ uint32_t id = (uint32_t) dd;
+ int32_t id1 = (int32_t) (id >> 1);
+ int32_t id2 = (int32_t) (id - id1);
- mp_int_set_value(K, digit, id1);
- mp_int_add_value(K, digit, id2, digit);
+ mp_int_set_value(K, digit, id1);
+ mp_int_add_value(K, digit, id2, digit);
- mp_int_mul_pow2(K, digit, power, digit);
- mp_int_add(K, res, digit, res);
+ mp_int_mul_pow2(K, digit, power, digit);
+ mp_int_add(K, res, digit, res);
- power += 32;
+ power += 32;
}
if (neg)
- mp_int_neg(K, res, res);
+ mp_int_neg(K, res, res);
krooted_tvs_pop(K); /* digit */
krooted_tvs_pop(K); /* res */
return tv_res; /* can't be fixint except when coming from
- kdouble_to_bigrat, so don't convert */
+ kdouble_to_bigrat, so don't convert */
}
/* TODO: should do something like rationalize with range +/- 1/2ulp) */
@@ -204,7 +204,7 @@ TValue kdouble_to_bigrat(klisp_State *K, double d)
{
bool neg = d < 0;
if (neg)
- d = -d;
+ d = -d;
/* find an integer, convert it and divide by
an adequate power of 2 */
@@ -219,13 +219,13 @@ TValue kdouble_to_bigrat(klisp_State *K, double d)
UNUSED(mp_int_set_value(K, den, 1));
/* XXX could be made a lot more efficiently reading ieee
- fields directly */
+ fields directly */
int ie;
d = frexp(d, &ie);
while(d != floor(d)) {
- d *= 2.0;
- --ie;
+ d *= 2.0;
+ --ie;
}
UNUSED(mp_int_mul_pow2(K, den, -ie, den));
@@ -244,7 +244,7 @@ TValue kdouble_to_bigrat(klisp_State *K, double d)
UNUSED(mp_rat_div(K, res, den2, res));
if (neg)
- UNUSED(mp_rat_neg(K, res, res));
+ UNUSED(mp_rat_neg(K, res, res));
/* now create a value corresponding to 1/2 ulp
for rationalize */
@@ -271,31 +271,31 @@ TValue kinexact_to_exact(klisp_State *K, TValue n)
case K_TBIGINT:
case K_TBIGRAT:
case K_TEINF:
- /* all of these are already exact */
- return n;
+ /* all of these are already exact */
+ return n;
case K_TDOUBLE: {
- double d = dvalue(n);
- klisp_assert(!isnan(d) && !isinf(d));
- if (d == floor(d)) { /* integer */
- if (d <= (double) INT32_MAX &&
- d >= (double) INT32_MIN) {
- return i2tv((int32_t) d); /* fixint */
- } else {
- return kdouble_to_bigint(K, d);
- }
- } else { /* non integer rational */
- return kdouble_to_bigrat(K, d);
- }
+ double d = dvalue(n);
+ klisp_assert(!isnan(d) && !isinf(d));
+ if (d == floor(d)) { /* integer */
+ if (d <= (double) INT32_MAX &&
+ d >= (double) INT32_MIN) {
+ return i2tv((int32_t) d); /* fixint */
+ } else {
+ return kdouble_to_bigint(K, d);
+ }
+ } else { /* non integer rational */
+ return kdouble_to_bigrat(K, d);
+ }
}
case K_TIINF:
- return tv_equal(n, KIPINF)? KEPINF : KEMINF;
+ return tv_equal(n, KIPINF)? KEPINF : KEMINF;
case K_TRWNPV:
case K_TUNDEFINED:
- klispE_throw_simple_with_irritants(K, "no primary value", 1, n);
- return KUNDEF;
+ klispE_throw_simple_with_irritants(K, "no primary value", 1, n);
+ return KUNDEF;
default:
- klisp_assert(0);
- return KUNDEF;
+ klisp_assert(0);
+ return KUNDEF;
}
}
@@ -321,14 +321,14 @@ mp_result shift_2(klisp_State *K, Bigint *x, Bigint *n, Bigint *r)
klisp_assert(res == MP_OK);
if (nv >= 0)
- return mp_int_mul_pow2(K, x, nv, r);
+ return mp_int_mul_pow2(K, x, nv, r);
else
- return mp_int_div_pow2(K, x, -nv, r, NULL);
+ return mp_int_div_pow2(K, x, -nv, r, NULL);
}
/* returns k, modifies all parameters (except f & p) */
int32_t simple_fixup(klisp_State *K, Bigint *f, Bigint *p, Bigint *r,
- Bigint *s, Bigint *mm, Bigint *mp)
+ Bigint *s, Bigint *mm, Bigint *mp)
{
mp_result res;
Bigint tmpz, tmpz2;
@@ -343,9 +343,9 @@ int32_t simple_fixup(klisp_State *K, Bigint *f, Bigint *p, Bigint *r,
res = shift_2(K, one, tmp, tmp);
if (mp_int_compare(f, tmp) == 0) {
- res = shift_2(K, mp, one, mp);
- res = shift_2(K, r, one, r);
- res = shift_2(K, s, one, s);
+ res = shift_2(K, mp, one, mp);
+ res = shift_2(K, r, one, r);
+ res = shift_2(K, s, one, s);
}
int k = 0;
@@ -355,13 +355,13 @@ int32_t simple_fixup(klisp_State *K, Bigint *f, Bigint *p, Bigint *r,
res = mp_int_div_value(K, tmp, 10, tmp, NULL);
while(mp_int_compare(r, tmp) < 0) {
- --k;
- res = mp_int_mul_value(K, r, 10, r);
- res = mp_int_mul_value(K, mm, 10, mm);
- res = mp_int_mul_value(K, mp, 10, mp);
- /* tmp = ceiling (s/10), for while guard */
- res = mp_int_add_value(K, s, 9, tmp);
- res = mp_int_div_value(K, tmp, 10, tmp, NULL);
+ --k;
+ res = mp_int_mul_value(K, r, 10, r);
+ res = mp_int_mul_value(K, mm, 10, mm);
+ res = mp_int_mul_value(K, mp, 10, mp);
+ /* tmp = ceiling (s/10), for while guard */
+ res = mp_int_add_value(K, s, 9, tmp);
+ res = mp_int_div_value(K, tmp, 10, tmp, NULL);
}
/* tmp = 2r + mp; tmp2 = 2s */
@@ -370,13 +370,13 @@ int32_t simple_fixup(klisp_State *K, Bigint *f, Bigint *p, Bigint *r,
res = mp_int_mul_value(K, s, 2, tmp2);
while(mp_int_compare(tmp, tmp2) >= 0) {
- res = mp_int_mul_value(K, s, 10, s);
- ++k;
+ res = mp_int_mul_value(K, s, 10, s);
+ ++k;
- /* tmp = 2r + mp; tmp2 = 2s */
- res = mp_int_mul_value(K, r, 2, tmp);
- res = mp_int_add(K, tmp, mp, tmp);
- res = mp_int_mul_value(K, s, 2, tmp2);
+ /* tmp = 2r + mp; tmp2 = 2s */
+ res = mp_int_mul_value(K, r, 2, tmp);
+ res = mp_int_add(K, tmp, mp, tmp);
+ res = mp_int_mul_value(K, s, 2, tmp2);
}
mp_int_clear(K, tmp);
@@ -390,7 +390,7 @@ int32_t simple_fixup(klisp_State *K, Bigint *f, Bigint *p, Bigint *r,
#define digit_pos(k_, upoint_) ((k_) + (upoint_))
bool dtoa(klisp_State *K, double d, char *buf, int32_t upoint, int32_t *out_h,
- int32_t *out_k)
+ int32_t *out_k)
{
assert(sizeof(mp_small) == 4);
mp_result res;
@@ -409,14 +409,14 @@ bool dtoa(klisp_State *K, double d, char *buf, int32_t upoint, int32_t *out_h,
/* this could be a binary search, it could also be done reading the exponent
field of ieee754 directly... */
while(mantissa != floor(mantissa)) {
- mantissa *= 2.0;
- ++ip;
+ mantissa *= 2.0;
+ ++ip;
}
/* mantissa is int & < 2^ip (was < 1=2^0 and by induction...) */
klisp_assert(mantissa * pow(2.0, ie - ip) == d);
/* mantissa is at most 53 bits long as an int, load it in two parts
- to f */
+ to f */
int64_t im = (int64_t) mantissa;
/* f */
/* cant load 32 bits at a time, second param is signed!,
@@ -428,8 +428,8 @@ bool dtoa(klisp_State *K, double d, char *buf, int32_t upoint, int32_t *out_h,
/* adjust f & p so that p is 53 TODO do in one step */
/* XXX: is this is ok for denorms?? */
while(ip < 53) {
- ++ip;
- res = mp_int_mul_value(K, &f, 2, &f);
+ ++ip;
+ res = mp_int_mul_value(K, &f, 2, &f);
}
/* e */
@@ -458,14 +458,14 @@ bool dtoa(klisp_State *K, double d, char *buf, int32_t upoint, int32_t *out_h,
// shift_2(f, max(e-p, 0), r);
// shift_2(1, max(-(e-p), 0), r);
if (mp_int_compare_zero(&e_p) >= 0) {
- res = shift_2(K, &f, &e_p, &r);
- res = shift_2(K, &one, &zero, &s); /* nop */
- res = shift_2(K, &one, &e_p, &mm);
+ res = shift_2(K, &f, &e_p, &r);
+ res = shift_2(K, &one, &zero, &s); /* nop */
+ res = shift_2(K, &one, &e_p, &mm);
} else {
- res = shift_2(K, &f, &zero, &r); /* nop */
- res = mp_int_neg(K, &e_p, &e_p);
- res = shift_2(K, &one, &e_p, &s);
- res = shift_2(K, &one, &zero, &mm);
+ res = shift_2(K, &f, &zero, &r); /* nop */
+ res = mp_int_neg(K, &e_p, &e_p);
+ res = shift_2(K, &one, &e_p, &s);
+ res = shift_2(K, &one, &zero, &mm);
}
mp_int_copy(K, &mm, &mp);
@@ -479,37 +479,37 @@ bool dtoa(klisp_State *K, double d, char *buf, int32_t upoint, int32_t *out_h,
bool low, high;
do {
- --k;
- res = mp_int_mul_value(K, &r, 10, &tmp);
- res = mp_int_div(K, &tmp, &s, &u, &r);
- res = mp_int_mul_value(K, &mm, 10, &mm);
- res = mp_int_mul_value(K, &mp, 10, &mp);
-
- /* low/high flags */
- /* XXX try to make 1e23 round correctly,
- it causes tmp == tmp2 but should probably
- check oddness of digit and (may result in a digit
- with value 10?, needing to backtrack)
- In general make it so that if rounding done at reading
- (should be round to even) is accounted for and the minimal
- length number is generated */
-
- res = mp_int_mul_value(K, &r, 2, &tmp);
-
- low = mp_int_compare(&tmp, &mm) < 0;
-
- res = mp_int_mul_value(K, &s, 2, &tmp2);
- res = mp_int_sub(K, &tmp2, &mp, &tmp2);
-
- high = mp_int_compare(&tmp, &tmp2) > 0;
-
- if (!low && !high) {
- mp_small digit;
- res = mp_int_to_int(&u, &digit);
- klisp_assert(res == MP_OK);
- klisp_assert(digit >= 0 && digit <= 9);
- buf[digit_pos(k, upoint)] = '0' + digit;
- }
+ --k;
+ res = mp_int_mul_value(K, &r, 10, &tmp);
+ res = mp_int_div(K, &tmp, &s, &u, &r);
+ res = mp_int_mul_value(K, &mm, 10, &mm);
+ res = mp_int_mul_value(K, &mp, 10, &mp);
+
+ /* low/high flags */
+ /* XXX try to make 1e23 round correctly,
+ it causes tmp == tmp2 but should probably
+ check oddness of digit and (may result in a digit
+ with value 10?, needing to backtrack)
+ In general make it so that if rounding done at reading
+ (should be round to even) is accounted for and the minimal
+ length number is generated */
+
+ res = mp_int_mul_value(K, &r, 2, &tmp);
+
+ low = mp_int_compare(&tmp, &mm) < 0;
+
+ res = mp_int_mul_value(K, &s, 2, &tmp2);
+ res = mp_int_sub(K, &tmp2, &mp, &tmp2);
+
+ high = mp_int_compare(&tmp, &tmp2) > 0;
+
+ if (!low && !high) {
+ mp_small digit;
+ res = mp_int_to_int(&u, &digit);
+ klisp_assert(res == MP_OK);
+ klisp_assert(digit >= 0 && digit <= 9);
+ buf[digit_pos(k, upoint)] = '0' + digit;
+ }
} while(!low && !high);
mp_small digit;
@@ -518,16 +518,16 @@ bool dtoa(klisp_State *K, double d, char *buf, int32_t upoint, int32_t *out_h,
klisp_assert(digit >= 0 && digit <= 9);
if (low && high) {
- res = mp_int_mul_value(K, &r, 2, &tmp);
- int cmp = mp_int_compare(&tmp, &s);
- if ((cmp == 0 && (digit & 1) != 0) || cmp > 0)
- ++digit;
+ res = mp_int_mul_value(K, &r, 2, &tmp);
+ int cmp = mp_int_compare(&tmp, &s);
+ if ((cmp == 0 && (digit & 1) != 0) || cmp > 0)
+ ++digit;
} else if (low) {
- /* nothing */
+ /* nothing */
} else if (high) {
- ++digit;
+ ++digit;
} else {
- assert(0);
+ assert(0);
}
/* double check in case there was an increment */
klisp_assert(digit >= 0 && digit <= 9);
@@ -568,7 +568,7 @@ int32_t kdouble_print_size(TValue tv_double)
}
void kdouble_print_string(klisp_State *K, TValue tv_double,
- char *buf, int32_t limit)
+ char *buf, int32_t limit)
{
klisp_assert(ttisdouble(tv_double));
/* TODO: add exponent to values too large or too small */
@@ -582,16 +582,16 @@ void kdouble_print_string(klisp_State *K, TValue tv_double,
/* dtoa only works for d > 0 */
if (od == 0.0) {
- buf[0] = '0';
- buf[1] = '.';
- buf[2] = '0';
- buf[3] = '\0';
- return;
+ buf[0] = '0';
+ buf[1] = '.';
+ buf[2] = '0';
+ buf[3] = '\0';
+ return;
}
double d;
if (od < 0.0)
- d = -od;
+ d = -od;
else d = od;
/* XXX this doesn't check limit, it should be large enough */
@@ -607,15 +607,15 @@ void kdouble_print_string(klisp_State *K, TValue tv_double,
int32_t start = upoint+k;
/* first reverse the digits */
for (int32_t i = upoint+k, j = upoint+h; i < j; i++, j--) {
- char ch = buf[i];
- buf[i] = buf[j];
- buf[j] = ch;
+ char ch = buf[i];
+ buf[i] = buf[j];
+ buf[j] = ch;
}
/* TODO use exponents */
/* if necessary make room for leading zeros and sign,
- move all to the left */
+ move all to the left */
int extra_size = (od < 0? 1 : 0) + (h < 0? 2 + (-h-1) : 0);
@@ -624,38 +624,38 @@ void kdouble_print_string(klisp_State *K, TValue tv_double,
int32_t i = 0;
if (od < 0)
- buf[i++] = '-';
+ buf[i++] = '-';
if (h < 0) {
- /* fraction with leading 0. and with possibly more leading zeros */
- buf[i++] = '0';
- buf[i++] = '.';
- for (int32_t j = -1; j > h; j--) {
- buf[i++] = '0';
- }
- int frac_size = size;
- i += frac_size;
- buf[i++] = '\0';
+ /* fraction with leading 0. and with possibly more leading zeros */
+ buf[i++] = '0';
+ buf[i++] = '.';
+ for (int32_t j = -1; j > h; j--) {
+ buf[i++] = '0';
+ }
+ int frac_size = size;
+ i += frac_size;
+ buf[i++] = '\0';
} else if (k >= 0) {
- /* integer with possibly trailing zeros */
- klisp_assert(size+extra_size+k+4 < limit);
- int int_size = size;
- i += int_size;
- for (int32_t j = 0; j < k; j++) {
- buf[i++] = '0';
- }
- buf[i++] = '.';
- buf[i++] = '0';
- buf[i++] = '\0';
+ /* integer with possibly trailing zeros */
+ klisp_assert(size+extra_size+k+4 < limit);
+ int int_size = size;
+ i += int_size;
+ for (int32_t j = 0; j < k; j++) {
+ buf[i++] = '0';
+ }
+ buf[i++] = '.';
+ buf[i++] = '0';
+ buf[i++] = '\0';
} else { /* both integer and fractional part, make room for the point */
- /* k < 0, h >= 0 */
- int32_t int_size = h+1;
- int32_t frac_size = -k;
- memmove(buf+i+int_size+1, buf+i+int_size, frac_size);
- i += int_size;
- buf[i++] = '.';
- i += frac_size;
- buf[i++] = '\0';
+ /* k < 0, h >= 0 */
+ int32_t int_size = h+1;
+ int32_t frac_size = -k;
+ memmove(buf+i+int_size+1, buf+i+int_size, frac_size);
+ i += int_size;
+ buf[i++] = '.';
+ i += frac_size;
+ buf[i++] = '\0';
}
return;
}
@@ -668,13 +668,13 @@ double kdouble_div_mod(double n, double d, double *res_mod)
/* div, mod or div-and-mod */
/* 0 <= mod0 < |d| */
if (mod < 0.0) {
- if (d < 0.0) {
- mod -= d;
- div += 1.0;
- } else {
- mod += d;
- div -= 1.0;
- }
+ if (d < 0.0) {
+ mod -= d;
+ div += 1.0;
+ } else {
+ mod += d;
+ div -= 1.0;
+ }
}
*res_mod = mod;
return div;
@@ -696,21 +696,21 @@ double kdouble_div0_mod0(double n, double d, double *res_mod)
double dmax = (d<0.0? -d : d) / 2.0;
if (mod < dmin) {
- if (d < 0) {
- mod -= d;
- div += 1.0;
- } else {
- mod += d;
- div -= 1.0;
- }
+ if (d < 0) {
+ mod -= d;
+ div += 1.0;
+ } else {
+ mod += d;
+ div -= 1.0;
+ }
} else if (mod >= dmax) {
- if (d < 0) {
- mod += d;
- div += 1.0;
- } else {
- mod -= d;
- div -= 1.0;
- }
+ if (d < 0) {
+ mod += d;
+ div += 1.0;
+ } else {
+ mod -= d;
+ div -= 1.0;
+ }
}
*res_mod = mod;
return div;
@@ -721,19 +721,19 @@ TValue kdouble_to_integer(klisp_State *K, TValue tv_double, kround_mode mode)
double d = dvalue(tv_double);
switch(mode) {
case K_TRUNCATE:
- d = trunc(d);
- break;
+ d = trunc(d);
+ break;
case K_CEILING:
- d = ceil(d);
- break;
+ d = ceil(d);
+ break;
case K_FLOOR:
- d = floor(d);
- break;
+ d = floor(d);
+ break;
case K_ROUND_EVEN: {
- int res = fesetround(FE_TONEAREST); /* REFACTOR: should be done once only... */
- klisp_assert(res == 0);
- d = nearbyint(d);
- break;
+ int res = fesetround(FE_TONEAREST); /* REFACTOR: should be done once only... */
+ klisp_assert(res == 0);
+ d = nearbyint(d);
+ break;
}
}
/* ASK John: we currently return inexact if given inexact is this ok?
diff --git a/src/kreal.h b/src/kreal.h
@@ -18,7 +18,7 @@
#include "imrat.h"
/* REFACTOR rename. These can take any real, but
- kreal_to_... is taken by kgnumbers... */
+ kreal_to_... is taken by kgnumbers... */
TValue kexact_to_inexact(klisp_State *K, TValue n);
TValue kinexact_to_exact(klisp_State *K, TValue n);
@@ -33,6 +33,6 @@ TValue kdouble_to_integer(klisp_State *K, TValue tv_double, kround_mode mode);
*/
int32_t kdouble_print_size(TValue tv_double);
void kdouble_print_string(klisp_State *K, TValue tv_double,
- char *buf, int32_t limit);
+ char *buf, int32_t limit);
#endif
diff --git a/src/krepl.c b/src/krepl.c
@@ -65,21 +65,21 @@ void do_repl_eval(klisp_State *K)
TValue denv = xparams[0];
if (ttiseof(obj)) {
- /* read [EOF], should terminate the repl */
- /* this will in turn call main_cont */
- /* print a newline to allow the shell a fresh line */
- printf("\n");
- /* This is ok because there is no interception possible */
- kset_cc(K, K->root_cont);
- kapply_cc(K, KINERT);
+ /* read [EOF], should terminate the repl */
+ /* this will in turn call main_cont */
+ /* print a newline to allow the shell a fresh line */
+ printf("\n");
+ /* This is ok because there is no interception possible */
+ kset_cc(K, K->root_cont);
+ kapply_cc(K, KINERT);
} else {
- /* save the source code info of the object in loop_cont
- before evaling */
+ /* save the source code info of the object in loop_cont
+ before evaling */
#if KTRACK_SI
- kset_source_info(K, kget_cc(K), ktry_get_si(K, obj));
+ kset_source_info(K, kget_cc(K), ktry_get_si(K, obj));
#endif
- ktail_eval(K, obj, denv);
+ ktail_eval(K, obj, denv);
}
}
@@ -106,11 +106,11 @@ void create_loop(klisp_State *K, TValue denv)
TValue env = kmake_empty_environment(K);
krooted_tvs_push(K, env);
TValue outer_cont = kmake_continuation(K, K->root_cont,
- do_pass_value, 2, entry_guards, env);
+ do_pass_value, 2, entry_guards, env);
kset_outer_cont(outer_cont);
krooted_tvs_push(K, outer_cont);
TValue inner_cont = kmake_continuation(K, outer_cont,
- do_pass_value, 2, exit_guards, env);
+ do_pass_value, 2, exit_guards, env);
kset_inner_cont(inner_cont);
krooted_tvs_pop(K); krooted_tvs_pop(K); krooted_tvs_pop(K);
@@ -118,7 +118,7 @@ void create_loop(klisp_State *K, TValue denv)
krooted_tvs_push(K, inner_cont);
TValue loop_cont =
- kmake_continuation(K, inner_cont, do_repl_loop, 1, denv);
+ kmake_continuation(K, inner_cont, do_repl_loop, 1, denv);
krooted_tvs_pop(K); /* in loop cont */
krooted_tvs_push(K, loop_cont);
TValue eval_cont = kmake_continuation(K, loop_cont, do_repl_eval, 1, denv);
@@ -176,66 +176,66 @@ void do_repl_int_error(klisp_State *K)
/* TEMP: obj should be an error obj */
if (ttiserror(obj)) {
- Error *err_obj = tv2error(obj);
- TValue who = err_obj->who;
- char *who_str;
- /* TEMP? */
- if (ttiscontinuation(who))
- who = tv2cont(who)->comb;
-
- if (ttisstring(who)) {
- who_str = kstring_buf(who);
+ Error *err_obj = tv2error(obj);
+ TValue who = err_obj->who;
+ char *who_str;
+ /* TEMP? */
+ if (ttiscontinuation(who))
+ who = tv2cont(who)->comb;
+
+ if (ttisstring(who)) {
+ who_str = kstring_buf(who);
#if KTRACK_NAMES
- } else if (khas_name(who)) {
- TValue name = kget_name(K, who);
- who_str = ksymbol_buf(name);
+ } else if (khas_name(who)) {
+ TValue name = kget_name(K, who);
+ who_str = ksymbol_buf(name);
#endif
- } else {
- who_str = "?";
- }
- char *msg = kstring_buf(err_obj->msg);
- fprintf(stderr, "\n*ERROR*: \n");
- fprintf(stderr, "%s: %s", who_str, msg);
-
- krooted_tvs_push(K, obj);
-
- /* Msg + irritants */
- /* TODO move to a new function */
- if (!ttisnil(err_obj->irritants)) {
- fprintf(stderr, ": ");
- kwrite_display_to_port(K, port, err_obj->irritants, false);
- }
- kwrite_newline_to_port(K, port);
+ } else {
+ who_str = "?";
+ }
+ char *msg = kstring_buf(err_obj->msg);
+ fprintf(stderr, "\n*ERROR*: \n");
+ fprintf(stderr, "%s: %s", who_str, msg);
+
+ krooted_tvs_push(K, obj);
+
+ /* Msg + irritants */
+ /* TODO move to a new function */
+ if (!ttisnil(err_obj->irritants)) {
+ fprintf(stderr, ": ");
+ kwrite_display_to_port(K, port, err_obj->irritants, false);
+ }
+ kwrite_newline_to_port(K, port);
#if KTRACK_NAMES
#if KTRACK_SI
- /* Location */
- /* TODO move to a new function */
- /* MAYBE: remove */
- if (khas_name(who) || khas_si(who)) {
- fprintf(stderr, "Location: ");
- kwrite_display_to_port(K, port, who, false);
- kwrite_newline_to_port(K, port);
- }
-
- /* Backtrace */
- /* TODO move to a new function */
- TValue tv_cont = err_obj->cont;
- fprintf(stderr, "Backtrace: \n");
- while(ttiscontinuation(tv_cont)) {
- kwrite_display_to_port(K, port, tv_cont, false);
- kwrite_newline_to_port(K, port);
- Continuation *cont = tv2cont(tv_cont);
- tv_cont = cont->parent;
- }
- /* add extra newline at the end */
- kwrite_newline_to_port(K, port);
+ /* Location */
+ /* TODO move to a new function */
+ /* MAYBE: remove */
+ if (khas_name(who) || khas_si(who)) {
+ fprintf(stderr, "Location: ");
+ kwrite_display_to_port(K, port, who, false);
+ kwrite_newline_to_port(K, port);
+ }
+
+ /* Backtrace */
+ /* TODO move to a new function */
+ TValue tv_cont = err_obj->cont;
+ fprintf(stderr, "Backtrace: \n");
+ while(ttiscontinuation(tv_cont)) {
+ kwrite_display_to_port(K, port, tv_cont, false);
+ kwrite_newline_to_port(K, port);
+ Continuation *cont = tv2cont(tv_cont);
+ tv_cont = cont->parent;
+ }
+ /* add extra newline at the end */
+ kwrite_newline_to_port(K, port);
#endif
#endif
- krooted_tvs_pop(K);
+ krooted_tvs_pop(K);
} else {
- fprintf(stderr, "\n*ERROR*: not an error object passed to "
- "error continuation\n\n");
+ fprintf(stderr, "\n*ERROR*: not an error object passed to "
+ "error continuation\n\n");
}
UNUSED(divert);
@@ -250,12 +250,12 @@ void kinit_repl(klisp_State *K)
{
TValue std_env = K->next_env;
- #if KTRACK_SI
+#if KTRACK_SI
/* save the root cont in next_si to let the loop continuations have
source info, this is hackish but works */
K->next_si = ktry_get_si(K, K->root_cont);
- #endif
+#endif
/* GC: create_loop will root std_env */
create_loop(K, std_env);
diff --git a/src/kstate.c b/src/kstate.c
@@ -53,14 +53,14 @@ klisp_State *klisp_newstate (klisp_Alloc f, void *ud) {
if (k == NULL) return NULL;
void *s = (*f)(ud, NULL, 0, KS_ISSIZE * sizeof(TValue));
if (s == NULL) {
- (*f)(ud, k, state_size(), 0);
- return NULL;
+ (*f)(ud, k, state_size(), 0);
+ return NULL;
}
void *b = (*f)(ud, NULL, 0, KS_ITBSIZE);
if (b == NULL) {
- (*f)(ud, k, state_size(), 0);
- (*f)(ud, s, KS_ISSIZE * sizeof(TValue), 0);
- return NULL;
+ (*f)(ud, k, state_size(), 0);
+ (*f)(ud, s, KS_ISSIZE * sizeof(TValue), 0);
+ return NULL;
}
K = (klisp_State *) k;
@@ -110,10 +110,10 @@ klisp_State *klisp_newstate (klisp_Alloc f, void *ud) {
K->weak = NULL;
K->tmudata = NULL;
K->totalbytes = state_size() + KS_ISSIZE * sizeof(TValue) +
- KS_ITBSIZE;
+ KS_ITBSIZE;
K->GCthreshold = UINT32_MAX; /* we still have a lot of allocation
- to do, put a very high value to
- avoid collection */
+ to do, put a very high value to
+ avoid collection */
K->estimate = 0; /* doesn't matter, it is set by gc later */
K->gcdept = 0;
K->gcpause = KLISPI_GCPAUSE;
@@ -123,8 +123,8 @@ klisp_State *klisp_newstate (klisp_Alloc f, void *ud) {
/* do nothing for now */
/* init the stacks used to protect variables & values from gc,
- this should be done before any new object is created because
- they are used by them */
+ this should be done before any new object is created because
+ they are used by them */
K->rooted_tvs_top = 0;
K->rooted_vars_top = 0;
@@ -140,10 +140,10 @@ klisp_State *klisp_newstate (klisp_Alloc f, void *ud) {
/* needs weak keys, otherwise every named object would
be fixed! */
K->name_table = klispH_new(K, 0, MINNAMETABSIZE,
- K_FLAG_WEAK_KEYS);
+ K_FLAG_WEAK_KEYS);
/* here the keys are uncollectable */
K->cont_name_table = klispH_new(K, 0, MINCONTNAMETABSIZE,
- K_FLAG_WEAK_NOTHING);
+ K_FLAG_WEAK_NOTHING);
/* Empty string */
/* MAYBE: fix it so we can remove empty_string from roots */
@@ -194,16 +194,16 @@ klisp_State *klisp_newstate (klisp_Alloc f, void *ud) {
/* initialize require facilities */
{
- char *str = getenv(KLISP_PATH);
- if (str == NULL)
- str = KLISP_PATH_DEFAULT;
+ char *str = getenv(KLISP_PATH);
+ if (str == NULL)
+ str = KLISP_PATH_DEFAULT;
- K->require_path = kstring_new_b_imm(K, str);
- /* replace dirsep with forward slashes,
- windows will happily accept forward slashes */
- str = kstring_buf(K->require_path);
- while ((str = strchr(str, *KLISP_DIRSEP)) != NULL)
- *str++ = '/';
+ K->require_path = kstring_new_b_imm(K, str);
+ /* replace dirsep with forward slashes,
+ windows will happily accept forward slashes */
+ str = kstring_buf(K->require_path);
+ while ((str = strchr(str, *KLISP_DIRSEP)) != NULL)
+ *str++ = '/';
}
K->require_table = klispH_new(K, 0, MINREQUIRETABSIZE, 0);
@@ -217,11 +217,11 @@ klisp_State *klisp_newstate (klisp_Alloc f, void *ud) {
/* the dynamic ports and the keys for the dynamic ports */
TValue in_port = kmake_std_fport(K, kstring_new_b_imm(K, "*STDIN*"),
- false, false, stdin);
+ false, false, stdin);
TValue out_port = kmake_std_fport(K, kstring_new_b_imm(K, "*STDOUT*"),
- true, false, stdout);
+ true, false, stdout);
TValue error_port = kmake_std_fport(K, kstring_new_b_imm(K, "*STDERR*"),
- true, false, stderr);
+ true, false, stderr);
K->kd_in_port_key = kcons(K, KTRUE, in_port);
K->kd_out_port_key = kcons(K, KTRUE, out_port);
K->kd_error_port_key = kcons(K, KTRUE, error_port);
@@ -235,7 +235,7 @@ klisp_State *klisp_newstate (klisp_Alloc f, void *ud) {
K->eval_op = kmake_operative(K, keval_ofn, 0), line_number = __LINE__;
#if KTRACK_SI
si = kcons(K, kstring_new_b_imm(K, __FILE__),
- kcons(K, i2tv(line_number), i2tv(0)));
+ kcons(K, i2tv(line_number), i2tv(0)));
kset_source_info(K, K->eval_op, si);
#endif
/* TODO: si */
@@ -245,7 +245,7 @@ klisp_State *klisp_newstate (klisp_Alloc f, void *ud) {
K->list_app = kmake_applicative(K, list, 0), line_number = __LINE__;
#if KTRACK_SI
si = kcons(K, kstring_new_b_imm(K, __FILE__),
- kcons(K, i2tv(__LINE__), i2tv(0)));
+ kcons(K, i2tv(__LINE__), i2tv(0)));
kset_source_info(K, K->list_app, si);
kset_source_info(K, kunwrap(K->list_app), si);
#endif
@@ -253,7 +253,7 @@ klisp_State *klisp_newstate (klisp_Alloc f, void *ud) {
K->memoize_app = kmake_applicative(K, memoize, 0), line_number = __LINE__;
#if KTRACK_SI
si = kcons(K, kstring_new_b_imm(K, __FILE__),
- kcons(K, i2tv(__LINE__), i2tv(0)));
+ kcons(K, i2tv(__LINE__), i2tv(0)));
kset_source_info(K, K->memoize_app, si);
kset_source_info(K, kunwrap(K->memoize_app), si);
#endif
@@ -266,25 +266,25 @@ klisp_State *klisp_newstate (klisp_Alloc f, void *ud) {
K->module_params_sym = ksymbol_new_b(K, "module-parameters", KNIL);
/* Create the root and error continuation (will be added to the
- environment in kinit_ground_env) */
+ environment in kinit_ground_env) */
K->root_cont = kmake_continuation(K, KNIL, do_root_exit, 0);
- #if KTRACK_SI
+#if KTRACK_SI
/* Add source info to the cont */
TValue str = kstring_new_b_imm(K, __FILE__);
TValue tail = kcons(K, i2tv(__LINE__), i2tv(0));
si = kcons(K, str, tail);
kset_source_info(K, K->root_cont, si);
- #endif
+#endif
K->error_cont = kmake_continuation(K, K->root_cont, do_error_exit, 0);
- #if KTRACK_SI
+#if KTRACK_SI
str = kstring_new_b_imm(K, __FILE__);
tail = kcons(K, i2tv(__LINE__), i2tv(0));
si = kcons(K, str, tail);
kset_source_info(K, K->error_cont, si);
- #endif
+#endif
/* this must be done before calling kinit_ground_env */
kinit_error_hierarchy(K);
@@ -312,7 +312,7 @@ void do_root_exit(klisp_State *K)
/* Just save the value and end the loop */
K->next_value = obj;
- K->next_func = NULL; /* force the loop to terminate */
+ K->next_func = NULL; /* force the loop to terminate */
return;
}
@@ -339,10 +339,10 @@ void ks_sgrow(klisp_State *K, int32_t new_top)
/* TEMP: do it naively for now */
size_t new_size = old_size * 2;
while(new_top > new_size)
- new_size *= 2;
+ new_size *= 2;
ks_sbuf(K) = klispM_realloc_(K, ks_sbuf(K), old_size*sizeof(TValue),
- new_size*sizeof(TValue));
+ new_size*sizeof(TValue));
ks_ssize(K) = new_size;
}
@@ -354,11 +354,11 @@ void ks_sshrink(klisp_State *K, int32_t new_top)
/* TEMP: do it naively for now */
size_t new_size = old_size;
while(new_size > KS_ISSIZE && new_top * 4 < new_size)
- new_size /= 2;
+ new_size /= 2;
/* NOTE: shrink can't fail */
ks_sbuf(K) = klispM_realloc_(K, ks_sbuf(K), old_size*sizeof(TValue),
- new_size*sizeof(TValue));
+ new_size*sizeof(TValue));
ks_ssize(K) = new_size;
}
@@ -371,10 +371,10 @@ void ks_tbgrow(klisp_State *K, int32_t new_top)
/* TEMP: do it naively for now */
size_t new_size = old_size * 2;
while(new_top > new_size)
- new_size *= 2;
+ new_size *= 2;
ks_tbuf(K) = klispM_realloc_(K, ks_tbuf(K), old_size*sizeof(TValue),
- new_size*sizeof(TValue));
+ new_size*sizeof(TValue));
ks_tbsize(K) = new_size;
}
@@ -386,11 +386,11 @@ void ks_tbshrink(klisp_State *K, int32_t new_top)
/* TEMP: do it naively for now */
size_t new_size = old_size;
while(new_size > KS_ISSIZE && new_top * 4 < new_size)
- new_size /= 2;
+ new_size /= 2;
/* NOTE: shrink can't fail */
ks_tbuf(K) = klispM_realloc_(K, ks_tbuf(K), old_size*sizeof(TValue),
- new_size*sizeof(TValue));
+ new_size*sizeof(TValue));
ks_tbsize(K) = new_size;
}
@@ -412,16 +412,16 @@ void ks_tbshrink(klisp_State *K, int32_t new_top)
void mark_iancestors(TValue cont)
{
while(!ttisnil(cont)) {
- kmark(cont);
- cont = tv2cont(cont)->parent;
+ kmark(cont);
+ cont = tv2cont(cont)->parent;
}
}
void unmark_iancestors(TValue cont)
{
while(!ttisnil(cont)) {
- kunmark(cont);
- cont = tv2cont(cont)->parent;
+ kunmark(cont);
+ cont = tv2cont(cont)->parent;
}
}
@@ -435,12 +435,12 @@ TValue select_interceptor(TValue guard_ls)
/* the guard list can't be cyclic, that case is
replaced by a simple list while copyng guards */
while(!ttisnil(guard_ls)) {
- /* entry is (selector . interceptor-op) */
- TValue entry = kcar(guard_ls);
- TValue selector = kcar(entry);
- if (kis_marked(selector))
- return kcdr(entry); /* only interceptor is important */
- guard_ls = kcdr(guard_ls);
+ /* entry is (selector . interceptor-op) */
+ TValue entry = kcar(guard_ls);
+ TValue selector = kcar(entry);
+ if (kis_marked(selector))
+ return kcdr(entry); /* only interceptor is important */
+ guard_ls = kcdr(guard_ls);
}
return KNIL;
}
@@ -452,7 +452,7 @@ TValue select_interceptor(TValue guard_ls)
/* GC: assume src_cont & dst_cont are rooted */
inline TValue create_interception_list(klisp_State *K, TValue src_cont,
- TValue dst_cont)
+ TValue dst_cont)
{
mark_iancestors(dst_cont);
TValue ilist = kcons(K, KNIL, KNIL);
@@ -465,28 +465,28 @@ inline TValue create_interception_list(klisp_State *K, TValue src_cont,
/* the loop is until we find the common ancestor, that has to be marked */
while(!kis_marked(cont)) {
- /* only inner conts have exit guards */
- if (kis_inner_cont(cont)) {
- klisp_assert(tv2cont(cont)->extra_size > 1);
- TValue entries = tv2cont(cont)->extra[0]; /* TODO make a macro */
+ /* only inner conts have exit guards */
+ if (kis_inner_cont(cont)) {
+ klisp_assert(tv2cont(cont)->extra_size > 1);
+ TValue entries = tv2cont(cont)->extra[0]; /* TODO make a macro */
- TValue interceptor = select_interceptor(entries);
- if (!ttisnil(interceptor)) {
+ TValue interceptor = select_interceptor(entries);
+ if (!ttisnil(interceptor)) {
/* TODO make macros */
- TValue denv = tv2cont(cont)->extra[1];
- TValue outer = tv2cont(cont)->parent;
- TValue outer_denv = kcons(K, outer, denv);
- krooted_tvs_push(K, outer_denv);
- TValue new_entry = kcons(K, interceptor, outer_denv);
- krooted_tvs_pop(K); /* already in entry */
- krooted_tvs_push(K, new_entry);
- TValue new_pair = kcons(K, new_entry, KNIL);
- krooted_tvs_pop(K);
- kset_cdr(tail, new_pair);
- tail = new_pair;
- }
- }
- cont = tv2cont(cont)->parent;
+ TValue denv = tv2cont(cont)->extra[1];
+ TValue outer = tv2cont(cont)->parent;
+ TValue outer_denv = kcons(K, outer, denv);
+ krooted_tvs_push(K, outer_denv);
+ TValue new_entry = kcons(K, interceptor, outer_denv);
+ krooted_tvs_pop(K); /* already in entry */
+ krooted_tvs_push(K, new_entry);
+ TValue new_pair = kcons(K, new_entry, KNIL);
+ krooted_tvs_pop(K);
+ kset_cdr(tail, new_pair);
+ tail = new_pair;
+ }
+ }
+ cont = tv2cont(cont)->parent;
}
unmark_iancestors(dst_cont);
@@ -501,26 +501,26 @@ inline TValue create_interception_list(klisp_State *K, TValue src_cont,
krooted_vars_push(K, &entry_int);
while(!kis_marked(cont)) {
- /* only outer conts have entry guards */
- if (kis_outer_cont(cont)) {
- klisp_assert(tv2cont(cont)->extra_size > 1);
- TValue entries = tv2cont(cont)->extra[0]; /* TODO make a macro */
- /* this is rooted because it's a substructure of entries */
- TValue interceptor = select_interceptor(entries);
- if (!ttisnil(interceptor)) {
+ /* only outer conts have entry guards */
+ if (kis_outer_cont(cont)) {
+ klisp_assert(tv2cont(cont)->extra_size > 1);
+ TValue entries = tv2cont(cont)->extra[0]; /* TODO make a macro */
+ /* this is rooted because it's a substructure of entries */
+ TValue interceptor = select_interceptor(entries);
+ if (!ttisnil(interceptor)) {
/* TODO make macros */
- TValue denv = tv2cont(cont)->extra[1];
- TValue outer = cont;
- TValue outer_denv = kcons(K, outer, denv);
- krooted_tvs_push(K, outer_denv);
- TValue new_entry = kcons(K, interceptor, outer_denv);
- krooted_tvs_pop(K); /* already in entry */
- krooted_tvs_push(K, new_entry);
- entry_int = kcons(K, new_entry, entry_int);
- krooted_tvs_pop(K);
- }
- }
- cont = tv2cont(cont)->parent;
+ TValue denv = tv2cont(cont)->extra[1];
+ TValue outer = cont;
+ TValue outer_denv = kcons(K, outer, denv);
+ krooted_tvs_push(K, outer_denv);
+ TValue new_entry = kcons(K, interceptor, outer_denv);
+ krooted_tvs_pop(K); /* already in entry */
+ krooted_tvs_push(K, new_entry);
+ entry_int = kcons(K, new_entry, entry_int);
+ krooted_tvs_pop(K);
+ }
+ }
+ cont = tv2cont(cont)->parent;
}
unmark_iancestors(src_cont);
@@ -557,32 +557,32 @@ void do_interception(klisp_State *K)
TValue ls = xparams[0];
TValue dst_cont = xparams[1];
if (ttisnil(ls)) {
- /* all interceptors returned normally */
- /* this is a normal pass/not subject to interception */
- kset_cc(K, dst_cont);
- kapply_cc(K, obj);
+ /* all interceptors returned normally */
+ /* this is a normal pass/not subject to interception */
+ kset_cc(K, dst_cont);
+ kapply_cc(K, obj);
} else {
- /* call the operative with the passed obj and applicative
- for outer cont as ptree in the dynamic environment of
- the corresponding call to guard-continuation in the
- dynamic extent of the associated outer continuation.
- If the operative normally returns a value, others
- interceptions should be scheduled */
- TValue first = kcar(ls);
- TValue op = kcar(first);
- TValue outer = kcadr(first);
- TValue denv = kcddr(first);
- TValue app = kmake_applicative(K, cont_app, 1, outer);
- krooted_tvs_push(K, app);
- TValue ptree = klist(K, 2, obj, app);
- krooted_tvs_pop(K); /* already in ptree */
- krooted_tvs_push(K, ptree);
- TValue new_cont = kmake_continuation(K, outer, do_interception,
- 2, kcdr(ls), dst_cont);
- kset_cc(K, new_cont);
- krooted_tvs_pop(K);
- /* XXX: what to pass as si? */
- ktail_call(K, op, ptree, denv);
+ /* call the operative with the passed obj and applicative
+ for outer cont as ptree in the dynamic environment of
+ the corresponding call to guard-continuation in the
+ dynamic extent of the associated outer continuation.
+ If the operative normally returns a value, others
+ interceptions should be scheduled */
+ TValue first = kcar(ls);
+ TValue op = kcar(first);
+ TValue outer = kcadr(first);
+ TValue denv = kcddr(first);
+ TValue app = kmake_applicative(K, cont_app, 1, outer);
+ krooted_tvs_push(K, app);
+ TValue ptree = klist(K, 2, obj, app);
+ krooted_tvs_pop(K); /* already in ptree */
+ krooted_tvs_push(K, ptree);
+ TValue new_cont = kmake_continuation(K, outer, do_interception,
+ 2, kcdr(ls), dst_cont);
+ kset_cc(K, new_cont);
+ krooted_tvs_pop(K);
+ /* XXX: what to pass as si? */
+ ktail_call(K, op, ptree, denv);
}
}
@@ -598,14 +598,14 @@ void kcall_cont(klisp_State *K, TValue dst_cont, TValue obj)
TValue int_ls = create_interception_list(K, src_cont, dst_cont);
TValue new_cont;
if (ttisnil(int_ls)) {
- new_cont = dst_cont; /* no interceptions */
+ new_cont = dst_cont; /* no interceptions */
} else {
- krooted_tvs_push(K, int_ls);
- /* we have to contruct a continuation to do the interceptions
- in order and finally call dst_cont if no divert occurs */
- new_cont = kmake_continuation(K, kget_cc(K), do_interception,
- 2, int_ls, dst_cont);
- krooted_tvs_pop(K);
+ krooted_tvs_push(K, int_ls);
+ /* we have to contruct a continuation to do the interceptions
+ in order and finally call dst_cont if no divert occurs */
+ new_cont = kmake_continuation(K, kget_cc(K), do_interception,
+ 2, int_ls, dst_cont);
+ krooted_tvs_pop(K);
}
/* no more allocation from this point */
krooted_tvs_pop(K);
@@ -631,19 +631,19 @@ void klispS_init_repl(klisp_State *K)
void klispS_run(klisp_State *K)
{
while(true) {
- if (setjmp(K->error_jb)) {
- /* continuation called */
- /* TEMP: do nothing, the loop will call the continuation */
- } else {
- /* all ok, continue with next func */
- while (K->next_func) {
- /* next_func is either operative or continuation
- but in any case the call is the same */
- (*(K->next_func))(K);
- }
- /* K->next_func is NULL, this means we should exit already */
- break;
- }
+ if (setjmp(K->error_jb)) {
+ /* continuation called */
+ /* TEMP: do nothing, the loop will call the continuation */
+ } else {
+ /* all ok, continue with next func */
+ while (K->next_func) {
+ /* next_func is either operative or continuation
+ but in any case the call is the same */
+ (*(K->next_func))(K);
+ }
+ /* K->next_func is NULL, this means we should exit already */
+ break;
+ }
}
}
diff --git a/src/kstate.h b/src/kstate.h
@@ -41,9 +41,9 @@ typedef struct {
/* in klisp this has both the immutable strings & the symbols */
typedef struct stringtable {
- GCObject **hash;
- uint32_t nuse; /* number of elements */
- int32_t size;
+ GCObject **hash;
+ uint32_t nuse; /* number of elements */
+ int32_t size;
} stringtable;
#define GC_PROTECT_SIZE 32
@@ -63,10 +63,10 @@ struct klisp_State {
** and otherwise next_func is from an operative
*/
TValue next_obj; /* this is the operative or continuation to call
- must be here to protect it from gc */
+ must be here to protect it from gc */
klisp_CFunction next_func; /* the next function to call
- (operative or continuation) */
- TValue next_value; /* the value to be passed to the next function */
+ (operative or continuation) */
+ TValue next_value; /* the value to be passed to the next function */
TValue next_env; /* either NIL or an environment for next operative */
TValue *next_xparams;
/* TODO replace with GCObject *next_si */
@@ -85,11 +85,11 @@ struct klisp_State {
TValue system_error_cont; /* initialized by kinit_error_hierarchy() */
klisp_Alloc frealloc; /* function to reallocate memory */
- void *ud; /* auxiliary data to `frealloc' */
+ void *ud; /* auxiliary data to `frealloc' */
/* GC */
uint16_t currentwhite; /* the one of the two whites that is in use in
- this collection cycle */
+ this collection cycle */
uint8_t gcstate; /* state of garbage collector */
int32_t sweepstrgc; /* position of sweep in `strt' */
GCObject *rootgc; /* list of all collectable objects */
@@ -108,7 +108,7 @@ struct klisp_State {
/* TEMP: error handling */
jmp_buf error_jb;
- /* input/output port in use (for read & write) */
+ /* input/output port in use (for read & write) */
TValue curr_port; /* save the port to update source info on errors */
/* for current-input-port, current-output-port, current-error-port */
@@ -179,19 +179,19 @@ struct klisp_State {
object pointed to by a variable may change */
int32_t rooted_vars_top;
TValue *rooted_vars_buf[GC_PROTECT_SIZE];
- };
+};
/* some size related macros */
#define KS_ISSIZE (1024)
#define KS_ITBSIZE (1024)
#define state_size() (sizeof(klisp_State))
- /*
- ** TEMP: for now use inlined functions, later check output in
- ** different compilers and/or profile to see if it's worthy to
- ** eliminate it, change it to compiler specific or replace it
- ** with defines
- */
+/*
+** TEMP: for now use inlined functions, later check output in
+** different compilers and/or profile to see if it's worthy to
+** eliminate it, change it to compiler specific or replace it
+** with defines
+*/
/*
** Stack functions
@@ -222,7 +222,7 @@ inline void ks_spush(klisp_State *K, TValue obj)
/* put check after so that there is always space for one obj, and if
realloc is needed, obj is already rooted */
if (ks_stop(K) == ks_ssize(K)) {
- ks_sgrow(K, ks_stop(K)+1);
+ ks_sgrow(K, ks_stop(K)+1);
}
}
@@ -230,7 +230,7 @@ inline void ks_spush(klisp_State *K, TValue obj)
inline TValue ks_spop(klisp_State *K)
{
if (ks_ssize(K) != KS_ISSIZE && ks_stop(K)-1 < (ks_ssize(K) / 4))
- ks_sshrink(K, ks_stop(K)-1);
+ ks_sshrink(K, ks_stop(K)-1);
TValue obj = ks_selem(K, ks_stop(K) - 1);
--ks_stop(K);
return obj;
@@ -246,14 +246,14 @@ inline void ks_sdiscardn(klisp_State *K, int32_t n)
int32_t new_top = ks_stop(K) - n;
ks_stop(K) = new_top;
if (ks_ssize(K) != KS_ISSIZE && new_top < (ks_ssize(K) / 4))
- ks_sshrink(K, new_top);
+ ks_sshrink(K, new_top);
return;
}
inline void ks_sclear(klisp_State *K)
{
if (ks_ssize(K) != KS_ISSIZE)
- ks_sshrink(K, 0);
+ ks_sshrink(K, 0);
ks_stop(K) = 0;
}
@@ -288,7 +288,7 @@ inline bool ks_tbisempty(klisp_State *K);
inline void ks_tbadd(klisp_State *K, char ch)
{
if (ks_tbidx(K) == ks_tbsize(K))
- ks_tbgrow(K, ks_tbidx(K)+1);
+ ks_tbgrow(K, ks_tbidx(K)+1);
ks_tbelem(K, ks_tbidx(K)) = ch;
++ks_tbidx(K);
}
@@ -301,7 +301,7 @@ inline char ks_tbget(klisp_State *K)
inline char ks_tbpop(klisp_State *K)
{
if (ks_tbsize(K) != KS_ITBSIZE && ks_tbidx(K)-1 < (ks_tbsize(K) / 4))
- ks_tbshrink(K, ks_tbidx(K)-1);
+ ks_tbshrink(K, ks_tbidx(K)-1);
char ch = ks_tbelem(K, ks_tbidx(K) - 1);
--ks_tbidx(K);
return ch;
@@ -316,7 +316,7 @@ inline char *ks_tbget_buffer(klisp_State *K)
inline void ks_tbclear(klisp_State *K)
{
if (ks_tbsize(K) != KS_ITBSIZE)
- ks_tbshrink(K, 0);
+ ks_tbshrink(K, 0);
ks_tbidx(K) = 0;
}
@@ -377,11 +377,11 @@ inline void kset_source_info(klisp_State *K, TValue obj, TValue si)
klisp_assert(kcan_have_si(obj));
klisp_assert(ttisnil(si) || ttispair(si));
if (ttisnil(si)) {
- gcvalue(obj)->gch.si = NULL;
- gcvalue(obj)->gch.kflags &= ~(K_FLAG_HAS_SI);
+ gcvalue(obj)->gch.si = NULL;
+ gcvalue(obj)->gch.kflags &= ~(K_FLAG_HAS_SI);
} else {
- gcvalue(obj)->gch.si = gcvalue(si);
- gcvalue(obj)->gch.kflags |= K_FLAG_HAS_SI;
+ gcvalue(obj)->gch.si = gcvalue(si);
+ gcvalue(obj)->gch.kflags |= K_FLAG_HAS_SI;
}
}
@@ -438,7 +438,7 @@ inline void klispS_set_cc(klisp_State *K, TValue new_cont)
#define kset_cc(K_, c_) (klispS_set_cc(K_, c_))
inline void klispS_tail_call_si(klisp_State *K, TValue top, TValue ptree,
- TValue env, TValue si)
+ TValue env, TValue si)
{
/* TODO write barriers */
@@ -457,21 +457,21 @@ inline void klispS_tail_call_si(klisp_State *K, TValue top, TValue ptree,
K->next_si = si;
}
-#define ktail_call_si(K_, op_, p_, e_, si_) \
+#define ktail_call_si(K_, op_, p_, e_, si_) \
{ klispS_tail_call_si((K_), (op_), (p_), (e_), (si_)); return; }
/* if no source info is needed */
-#define ktail_call(K_, op_, p_, e_) \
- { klisp_State *K__ = (K_); \
- TValue op__ = (op_); \
- (ktail_call_si(K__, op__, p_, e_, ktry_get_si(K__, op__))); } \
-
-#define ktail_eval(K_, p_, e_) \
- { klisp_State *K__ = (K_); \
- TValue p__ = (p_); \
- klispS_tail_call_si(K__, K__->eval_op, p__, (e_), \
- ktry_get_si(K__, p__)); \
- return; }
+#define ktail_call(K_, op_, p_, e_) \
+ { klisp_State *K__ = (K_); \
+ TValue op__ = (op_); \
+ (ktail_call_si(K__, op__, p_, e_, ktry_get_si(K__, op__))); } \
+
+#define ktail_eval(K_, p_, e_) \
+ { klisp_State *K__ = (K_); \
+ TValue p__ = (p_); \
+ klispS_tail_call_si(K__, K__->eval_op, p__, (e_), \
+ ktry_get_si(K__, p__)); \
+ return; }
/* helper for continuation->applicative & kcall_cont */
void cont_app(klisp_State *K);
diff --git a/src/kstring.c b/src/kstring.c
@@ -22,42 +22,42 @@ void klispS_resize (klisp_State *K, int32_t newsize)
stringtable *tb;
int32_t i;
if (K->gcstate == GCSsweepstring)
- return; /* cannot resize during GC traverse */
+ return; /* cannot resize during GC traverse */
newhash = klispM_newvector(K, newsize, GCObject *);
tb = &K->strt;
for (i = 0; i < newsize; i++) newhash[i] = NULL;
/* rehash */
for (i = 0; i < tb->size; i++) {
- GCObject *p = tb->hash[i];
- while (p) { /* for each node in the list */
- /* imm string, imm bytevectors & symbols aren't chained with
- all other objs, but with each other in strt */
- GCObject *next = p->gch.next; /* save next */
- uint32_t h = 0;
- klisp_assert(p->gch.tt == K_TKEYWORD || p->gch.tt == K_TSYMBOL ||
- p->gch.tt == K_TSTRING || p->gch.tt == K_TBYTEVECTOR);
-
- switch(p->gch.tt) {
- case K_TSYMBOL:
- h = ((Symbol *) p)->hash;
- break;
- case K_TSTRING:
- h = ((String *) p)->hash;
- break;
- case K_TBYTEVECTOR:
- h = ((Bytevector *) p)->hash;
- break;
- case K_TKEYWORD:
- h = ((Keyword *) p)->hash;
- break;
- }
-
- int32_t h1 = lmod(h, newsize); /* new position */
- klisp_assert((int32_t) (h%newsize) == lmod(h, newsize));
- p->gch.next = newhash[h1]; /* chain it */
- newhash[h1] = p;
- p = next;
- }
+ GCObject *p = tb->hash[i];
+ while (p) { /* for each node in the list */
+ /* imm string, imm bytevectors & symbols aren't chained with
+ all other objs, but with each other in strt */
+ GCObject *next = p->gch.next; /* save next */
+ uint32_t h = 0;
+ klisp_assert(p->gch.tt == K_TKEYWORD || p->gch.tt == K_TSYMBOL ||
+ p->gch.tt == K_TSTRING || p->gch.tt == K_TBYTEVECTOR);
+
+ switch(p->gch.tt) {
+ case K_TSYMBOL:
+ h = ((Symbol *) p)->hash;
+ break;
+ case K_TSTRING:
+ h = ((String *) p)->hash;
+ break;
+ case K_TBYTEVECTOR:
+ h = ((Bytevector *) p)->hash;
+ break;
+ case K_TKEYWORD:
+ h = ((Keyword *) p)->hash;
+ break;
+ }
+
+ int32_t h1 = lmod(h, newsize); /* new position */
+ klisp_assert((int32_t) (h%newsize) == lmod(h, newsize));
+ p->gch.next = newhash[h1]; /* chain it */
+ newhash[h1] = p;
+ p = next;
+ }
}
klispM_freearray(K, tb->hash, tb->size, GCObject *);
tb->size = newsize;
@@ -66,10 +66,10 @@ void klispS_resize (klisp_State *K, int32_t newsize)
/* General constructor for strings */
TValue kstring_new_bs_g(klisp_State *K, bool m, const char *buf,
- uint32_t size)
+ uint32_t size)
{
return m? kstring_new_bs(K, buf, size) :
- kstring_new_bs_imm(K, buf, size);
+ kstring_new_bs_imm(K, buf, size);
}
/*
@@ -82,24 +82,24 @@ TValue kstring_new_bs_imm(klisp_State *K, const char *buf, uint32_t size)
/* first check to see if it's in the stringtable */
uint32_t h = size; /* seed */
size_t step = (size>>5)+1; /* if string is too long, don't hash all
- its chars */
+ its chars */
size_t size1;
for (size1 = size; size1 >= step; size1 -= step) /* compute hash */
- h = h ^ ((h<<5)+(h>>2)+ ((unsigned char) buf[size1-1]));
+ h = h ^ ((h<<5)+(h>>2)+ ((unsigned char) buf[size1-1]));
for (GCObject *o = K->strt.hash[lmod(h, K->strt.size)];
- o != NULL; o = o->gch.next) {
- klisp_assert(o->gch.tt == K_TKEYWORD || o->gch.tt == K_TSYMBOL ||
- o->gch.tt == K_TSTRING || o->gch.tt == K_TBYTEVECTOR);
-
- if (o->gch.tt != K_TSTRING) continue;
-
- String *ts = (String *) o;
- if (ts->size == size && (memcmp(buf, ts->b, size) == 0)) {
- /* string may be dead */
- if (isdead(K, o)) changewhite(o);
- return gc2str(o);
- }
+ o != NULL; o = o->gch.next) {
+ klisp_assert(o->gch.tt == K_TKEYWORD || o->gch.tt == K_TSYMBOL ||
+ o->gch.tt == K_TSTRING || o->gch.tt == K_TBYTEVECTOR);
+
+ if (o->gch.tt != K_TSTRING) continue;
+
+ String *ts = (String *) o;
+ if (ts->size == size && (memcmp(buf, ts->b, size) == 0)) {
+ /* string may be dead */
+ if (isdead(K, o)) changewhite(o);
+ return gc2str(o);
+ }
}
/* If it exits the loop, it means it wasn't found, hash is still in h */
@@ -107,7 +107,7 @@ TValue kstring_new_bs_imm(klisp_State *K, const char *buf, uint32_t size)
String *new_str;
if (size > (SIZE_MAX - sizeof(String) - 1))
- klispM_toobig(K);
+ klispM_toobig(K);
new_str = (String *) klispM_malloc(K, sizeof(String) + size + 1);
@@ -123,7 +123,7 @@ TValue kstring_new_bs_imm(klisp_State *K, const char *buf, uint32_t size)
new_str->mark = KFALSE;
new_str->size = size;
if (size != 0) {
- memcpy(new_str->b, buf, size);
+ memcpy(new_str->b, buf, size);
}
new_str->b[size] = '\0'; /* final 0 for printing */
@@ -136,9 +136,9 @@ TValue kstring_new_bs_imm(klisp_State *K, const char *buf, uint32_t size)
tb->nuse++;
TValue ret_tv = gc2str(new_str);
if (tb->nuse > ((uint32_t) tb->size) && tb->size <= INT32_MAX / 2) {
- krooted_tvs_push(K, ret_tv); /* save in case of gc */
- klispS_resize(K, tb->size*2); /* too crowded */
- krooted_tvs_pop(K);
+ krooted_tvs_push(K, ret_tv); /* save in case of gc */
+ klispS_resize(K, tb->size*2); /* too crowded */
+ krooted_tvs_pop(K);
}
return ret_tv;
@@ -161,8 +161,8 @@ TValue kstring_new_s(klisp_State *K, uint32_t size)
String *new_str;
if (size == 0) {
- klisp_assert(ttisstring(K->empty_string));
- return K->empty_string;
+ klisp_assert(ttisstring(K->empty_string));
+ return K->empty_string;
}
new_str = klispM_malloc(K, sizeof(String) + size + 1);
@@ -215,10 +215,10 @@ bool kstring_equalp(TValue obj1, TValue obj2)
String *str2 = tv2str(obj2);
if (str1->size == str2->size) {
- return (str1->size == 0) ||
- (memcmp(str1->b, str2->b, str1->size) == 0);
+ return (str1->size == 0) ||
+ (memcmp(str1->b, str2->b, str1->size) == 0);
} else {
- return false;
+ return false;
}
}
diff --git a/src/kstring.h b/src/kstring.h
@@ -19,7 +19,7 @@ void klispS_resize (klisp_State *K, int32_t newsize);
/* General constructor for strings */
TValue kstring_new_bs_g(klisp_State *K, bool m, const char *buf,
- uint32_t size);
+ uint32_t size);
/*
** Constructors for immutable strings
@@ -55,7 +55,7 @@ TValue kstring_new_sf(klisp_State *K, uint32_t size, char fill);
#define kstring_immutablep(tv_) (kis_immutable(tv_))
/* both obj1 and obj2 should be strings, this compares char by char
- and doesn't differentiate immutable from mutable strings */
+ and doesn't differentiate immutable from mutable strings */
bool kstring_equalp(TValue obj1, TValue obj2);
bool kstringp(TValue obj);
bool kimmutable_stringp(TValue obj);
diff --git a/src/ksymbol.c b/src/ksymbol.c
@@ -28,35 +28,35 @@ TValue ksymbol_new_bs(klisp_State *K, const char *buf, int32_t size, TValue si)
/* First calculate the hash */
uint32_t h = size; /* seed */
size_t step = (size>>5)+1; /* if string is too long, don't hash all
- its chars */
+ its chars */
size_t size1;
for (size1 = size; size1 >= step; size1 -= step) /* compute hash */
- h = h ^ ((h<<5)+(h>>2)+ ((unsigned char) buf[size1-1]));
+ h = h ^ ((h<<5)+(h>>2)+ ((unsigned char) buf[size1-1]));
h = ~h; /* symbol hash should be different from string hash
- otherwise symbols and their respective immutable string
- would always fall in the same bucket */
+ otherwise symbols and their respective immutable string
+ would always fall in the same bucket */
/* look for it in the table only if it doesn't have source info */
if (ttisnil(si)) {
- for (GCObject *o = K->strt.hash[lmod(h, K->strt.size)];
- o != NULL; o = o->gch.next) {
- klisp_assert(o->gch.tt == K_TKEYWORD || o->gch.tt == K_TSYMBOL ||
- o->gch.tt == K_TSTRING || o->gch.tt == K_TBYTEVECTOR);
+ for (GCObject *o = K->strt.hash[lmod(h, K->strt.size)];
+ o != NULL; o = o->gch.next) {
+ klisp_assert(o->gch.tt == K_TKEYWORD || o->gch.tt == K_TSYMBOL ||
+ o->gch.tt == K_TSTRING || o->gch.tt == K_TBYTEVECTOR);
- if (o->gch.tt != K_TSYMBOL) continue;
+ if (o->gch.tt != K_TSYMBOL) continue;
- String *ts = tv2str(((Symbol *) o)->str);
- if (ts->size == size && (memcmp(buf, ts->b, size) == 0)) {
- /* symbol and/or string may be dead */
- if (isdead(K, o)) changewhite(o);
- if (isdead(K, (GCObject *) ts)) changewhite((GCObject *) ts);
- return gc2sym(o);
- }
- }
+ String *ts = tv2str(((Symbol *) o)->str);
+ if (ts->size == size && (memcmp(buf, ts->b, size) == 0)) {
+ /* symbol and/or string may be dead */
+ if (isdead(K, o)) changewhite(o);
+ if (isdead(K, (GCObject *) ts)) changewhite((GCObject *) ts);
+ return gc2sym(o);
+ }
+ }
}
/* REFACTOR: move this to a new function */
/* Didn't find it, alloc new immutable string and save in symbol table,
- note that the hash value remained in h */
+ note that the hash value remained in h */
TValue new_str = kstring_new_bs_imm(K, buf, size);
krooted_tvs_push(K, new_str);
Symbol *new_sym = klispM_new(K, Symbol);
@@ -64,42 +64,42 @@ TValue ksymbol_new_bs(klisp_State *K, const char *buf, int32_t size, TValue si)
krooted_tvs_pop(K);
if (ttisnil(si)) {
- /* header + gc_fields */
- /* can't use klispC_link, because strings use the next pointer
- differently */
- new_sym->gct = klispC_white(K);
- new_sym->tt = K_TSYMBOL;
- new_sym->kflags = 0;
- new_sym->si = NULL;
+ /* header + gc_fields */
+ /* can't use klispC_link, because strings use the next pointer
+ differently */
+ new_sym->gct = klispC_white(K);
+ new_sym->tt = K_TSYMBOL;
+ new_sym->kflags = 0;
+ new_sym->si = NULL;
- /* symbol specific fields */
- new_sym->str = new_str;
- new_sym->hash = h;
+ /* symbol specific fields */
+ new_sym->str = new_str;
+ new_sym->hash = h;
- /* add to the string/symbol table (and link it) */
- stringtable *tb;
- tb = &K->strt;
- h = lmod(h, tb->size);
- new_sym->next = tb->hash[h]; /* chain new entry */
- tb->hash[h] = (GCObject *)(new_sym);
- tb->nuse++;
- if (tb->nuse > ((uint32_t) tb->size) && tb->size <= INT32_MAX / 2) {
- krooted_tvs_push(K, ret_tv); /* save in case of gc */
- klispS_resize(K, tb->size*2); /* too crowded */
- krooted_tvs_pop(K);
- }
+ /* add to the string/symbol table (and link it) */
+ stringtable *tb;
+ tb = &K->strt;
+ h = lmod(h, tb->size);
+ new_sym->next = tb->hash[h]; /* chain new entry */
+ tb->hash[h] = (GCObject *)(new_sym);
+ tb->nuse++;
+ if (tb->nuse > ((uint32_t) tb->size) && tb->size <= INT32_MAX / 2) {
+ krooted_tvs_push(K, ret_tv); /* save in case of gc */
+ klispS_resize(K, tb->size*2); /* too crowded */
+ krooted_tvs_pop(K);
+ }
} else { /* non nil source info */
- /* link it with regular objects and save source info */
- /* header + gc_fields */
- klispC_link(K, (GCObject *) new_sym, K_TSYMBOL, 0);
+ /* link it with regular objects and save source info */
+ /* header + gc_fields */
+ klispC_link(K, (GCObject *) new_sym, K_TSYMBOL, 0);
- /* symbol specific fields */
- new_sym->str = new_str;
- new_sym->hash = h;
+ /* symbol specific fields */
+ new_sym->str = new_str;
+ new_sym->hash = h;
- krooted_tvs_push(K, ret_tv); /* not needed, but just in case */
- kset_source_info(K, ret_tv, si);
- krooted_tvs_pop(K);
+ krooted_tvs_push(K, ret_tv); /* not needed, but just in case */
+ kset_source_info(K, ret_tv, si);
+ krooted_tvs_pop(K);
}
return ret_tv;
}
diff --git a/src/ksymbol.h b/src/ksymbol.h
@@ -21,7 +21,7 @@
/* buffer + size, may contain nulls */
TValue ksymbol_new_bs(klisp_State *K, const char *buf, int32_t size,
- TValue si);
+ TValue si);
/* null terminated buffer */
TValue ksymbol_new_b(klisp_State *K, const char *buf, TValue si);
/* copies str if not immutable */
diff --git a/src/ksystem.c b/src/ksystem.c
@@ -45,7 +45,7 @@ TValue ksystem_current_jiffy(klisp_State *K)
klispE_throw_simple(K, "couldn't get time");
return KFALSE;
} else {
- return kinteger_new_uint64(K, (uint64_t) now);
+ return kinteger_new_uint64(K, (uint64_t) now);
}
}
diff --git a/src/ksystem.posix.c b/src/ksystem.posix.c
@@ -49,5 +49,5 @@ TValue ksystem_jiffies_per_second(klisp_State *K)
bool ksystem_isatty(klisp_State *K, TValue port)
{
return ttisfport(port) && kport_is_open(port)
- && isatty(fileno(kfport_file(port)));
+ && isatty(fileno(kfport_file(port)));
}
diff --git a/src/ksystem.win32.c b/src/ksystem.win32.c
@@ -57,7 +57,7 @@ bool ksystem_isatty(klisp_State *K, TValue port)
* - does not work on output handles
* - does not work in plain wine (works in wineconsole)
* - probably won't work if Windows Console is replaced
- * a terminal emulator
+ * a terminal emulator
*
* TEMP: use GetConsoleMode()
*/
diff --git a/src/ktable.c b/src/ktable.c
@@ -46,11 +46,11 @@
#define MAXASIZE (1 << MAXBITS)
-#define hashpow2(t,n) (gnode(t, lmod((n), sizenode(t))))
+#define hashpow2(t,n) (gnode(t, lmod((n), sizenode(t))))
#define hashstr(t,str) hashpow2(t, (str)->hash)
#define hashsym(t,sym) hashpow2(t, (sym)->hash)
-#define hashboolean(t,p) hashpow2(t, p? 1 : 0)
+#define hashboolean(t,p) hashpow2(t, p? 1 : 0)
/*
@@ -65,8 +65,8 @@
#define dummynode (&dummynode_)
static const Node dummynode_ = {
- .i_val = KFREE_,
- .i_key = { .nk = { .this = KFREE_, .next = NULL}}
+ .i_val = KFREE_,
+ .i_key = { .nk = { .this = KFREE_, .next = NULL}}
};
@@ -85,7 +85,7 @@ inline static Node *hashfixint (const Table *t, int32_t n) {
static Node *hashbigint (const Table *t, Bigint *b) {
uint32_t n = (b->sign == 0)? 0 : 1;
for (uint32_t i = 0; i < b->used; i++)
- n += b->digits[i];
+ n += b->digits[i];
return hashmod(t, n);
}
@@ -95,40 +95,40 @@ static Node *hashbigint (const Table *t, Bigint *b) {
** of its hash value)
*/
static Node *mainposition (const Table *t, TValue key) {
- switch (ttype(key)) {
- case K_TNIL:
- case K_TIGNORE:
- case K_TINERT:
- case K_TEOF:
- case K_TFIXINT:
- case K_TEINF: /* infinites have -1 or 1 as ivalues */
- return hashfixint(t, ivalue(key));
- case K_TCHAR:
- return hashfixint(t, chvalue(key));
- case K_TBIGINT:
- return hashbigint(t, tv2bigint(key));
- case K_TBOOLEAN:
- return hashboolean(t, bvalue(key));
- case K_TSTRING:
- if (kstring_immutablep(key))
- return hashstr(t, tv2str(key));
- else /* mutable strings are eq iff they are the same object */
- return hashpointer(t, gcvalue(key));
- case K_TSYMBOL:
- return hashsym(t, tv2sym(key));
- case K_TUSER:
- return hashpointer(t, pvalue(key));
- case K_TAPPLICATIVE:
- /* applicatives are eq if wrapping the same number of times the
- same applicative, just in case make the hash of an applicative
- the same as the hash of the operative is ultimately wraps */
- while(ttisapplicative(key)) {
- key = kunwrap(key);
- }
- /* fall through */
- default:
- return hashpointer(t, gcvalue(key));
- }
+ switch (ttype(key)) {
+ case K_TNIL:
+ case K_TIGNORE:
+ case K_TINERT:
+ case K_TEOF:
+ case K_TFIXINT:
+ case K_TEINF: /* infinites have -1 or 1 as ivalues */
+ return hashfixint(t, ivalue(key));
+ case K_TCHAR:
+ return hashfixint(t, chvalue(key));
+ case K_TBIGINT:
+ return hashbigint(t, tv2bigint(key));
+ case K_TBOOLEAN:
+ return hashboolean(t, bvalue(key));
+ case K_TSTRING:
+ if (kstring_immutablep(key))
+ return hashstr(t, tv2str(key));
+ else /* mutable strings are eq iff they are the same object */
+ return hashpointer(t, gcvalue(key));
+ case K_TSYMBOL:
+ return hashsym(t, tv2sym(key));
+ case K_TUSER:
+ return hashpointer(t, pvalue(key));
+ case K_TAPPLICATIVE:
+ /* applicatives are eq if wrapping the same number of times the
+ same applicative, just in case make the hash of an applicative
+ the same as the hash of the operative is ultimately wraps */
+ while(ttisapplicative(key)) {
+ key = kunwrap(key);
+ }
+ /* fall through */
+ default:
+ return hashpointer(t, gcvalue(key));
+ }
}
@@ -152,23 +152,23 @@ static int32_t findindex (klisp_State *K, Table *t, TValue key)
if (ttisfree(key)) return -1; /* first iteration */
i = arrayindex(key);
if (0 <= i && i < t->sizearray) /* is `key' inside array part? */
- return i; /* yes; that's the index */
+ return i; /* yes; that's the index */
else {
- Node *n = mainposition(t, key);
- do { /* check whether `key' is somewhere in the chain */
- /* key may be dead already, but it is ok to use it in `next' */
+ Node *n = mainposition(t, key);
+ do { /* check whether `key' is somewhere in the chain */
+ /* key may be dead already, but it is ok to use it in `next' */
/* klisp: i'm not so sure about this... */
- if (eq2p(K, key2tval(n), key) ||
- (ttype(gkey(n)->this) == K_TDEADKEY && iscollectable(key) &&
- gcvalue(gkey(n)->this) == gcvalue(key))) {
- i = (int32_t) (n - gnode(t, 0)); /* key index in hash table */
- /* hash elements are numbered after array ones */
- return i + t->sizearray;
- }
- else n = gnext(n);
- } while (n);
- klispE_throw_simple(K, "invalid key to next"); /* key not found */
- return 0; /* to avoid warnings */
+ if (eq2p(K, key2tval(n), key) ||
+ (ttype(gkey(n)->this) == K_TDEADKEY && iscollectable(key) &&
+ gcvalue(gkey(n)->this) == gcvalue(key))) {
+ i = (int32_t) (n - gnode(t, 0)); /* key index in hash table */
+ /* hash elements are numbered after array ones */
+ return i + t->sizearray;
+ }
+ else n = gnext(n);
+ } while (n);
+ klispE_throw_simple(K, "invalid key to next"); /* key not found */
+ return 0; /* to avoid warnings */
}
}
@@ -176,18 +176,18 @@ int32_t klispH_next (klisp_State *K, Table *t, TValue *key, TValue *data)
{
int32_t i = findindex(K, t, *key); /* find original element */
for (i++; i < t->sizearray; i++) { /* try first array part */
- if (!ttisfree(t->array[i])) { /* a non-nil value? */
- *key = i2tv(i);
- *data = t->array[i];
- return 1;
- }
+ if (!ttisfree(t->array[i])) { /* a non-nil value? */
+ *key = i2tv(i);
+ *data = t->array[i];
+ return 1;
+ }
}
for (i -= t->sizearray; i < sizenode(t); i++) { /* then hash part */
- if (!ttisfree(gval(gnode(t, i)))) { /* a non-nil value? */
- *key = key2tval(gnode(t, i));
- *data = gval(gnode(t, i));
- return 1;
- }
+ if (!ttisfree(gval(gnode(t, i)))) { /* a non-nil value? */
+ *key = key2tval(gnode(t, i));
+ *data = gval(gnode(t, i));
+ return 1;
+ }
}
return 0; /* no more elements */
}
@@ -208,14 +208,14 @@ static int32_t computesizes (int32_t nums[], int32_t *narray)
int32_t na = 0; /* number of elements to go to array part */
int32_t n = 0; /* optimal size for array part */
for (i = 0, twotoi = 1; twotoi/2 < *narray; i++, twotoi *= 2) {
- if (nums[i] > 0) {
- a += nums[i];
- if (a > twotoi/2) { /* more than half elements present? */
- n = twotoi; /* optimal size (till now) */
- na = a; /* all elements smaller than n will go to array part */
- }
- }
- if (a == *narray) break; /* all elements already counted */
+ if (nums[i] > 0) {
+ a += nums[i];
+ if (a > twotoi/2) { /* more than half elements present? */
+ n = twotoi; /* optimal size (till now) */
+ na = a; /* all elements smaller than n will go to array part */
+ }
+ }
+ if (a == *narray) break; /* all elements already counted */
}
*narray = n;
klisp_assert(*narray/2 <= na && na <= *narray);
@@ -227,11 +227,11 @@ static int32_t countint (const TValue key, int32_t *nums)
{
int32_t k = arrayindex(key);
if (0 < k && k <= MAXASIZE) { /* is `key' an appropriate array index? */
- nums[ceillog2(k)]++; /* count as such */
- return 1;
+ nums[ceillog2(k)]++; /* count as such */
+ return 1;
}
else
- return 0;
+ return 0;
}
@@ -242,20 +242,20 @@ static int32_t numusearray (const Table *t, int32_t *nums)
int32_t ause = 0; /* summation of `nums' */
int32_t i = 1; /* count to traverse all array keys */
for (lg=0, ttlg=1; lg<=MAXBITS; lg++, ttlg*=2) { /* for each slice */
- int32_t lc = 0; /* counter */
- int32_t lim = ttlg;
- if (lim > t->sizearray) {
- lim = t->sizearray; /* adjust upper limit */
- if (i > lim)
- break; /* no more elements to count */
- }
- /* count elements in range (2^(lg-1), 2^lg] */
- for (; i <= lim; i++) {
- if (!ttisfree(t->array[i-1]))
- lc++;
- }
- nums[lg] += lc;
- ause += lc;
+ int32_t lc = 0; /* counter */
+ int32_t lim = ttlg;
+ if (lim > t->sizearray) {
+ lim = t->sizearray; /* adjust upper limit */
+ if (i > lim)
+ break; /* no more elements to count */
+ }
+ /* count elements in range (2^(lg-1), 2^lg] */
+ for (; i <= lim; i++) {
+ if (!ttisfree(t->array[i-1]))
+ lc++;
+ }
+ nums[lg] += lc;
+ ause += lc;
}
return ause;
}
@@ -267,11 +267,11 @@ static int32_t numusehash (const Table *t, int32_t *nums, int32_t *pnasize)
int32_t ause = 0; /* summation of `nums' */
int32_t i = sizenode(t);
while (i--) {
- Node *n = &t->node[i];
- if (!ttisfree(gval(n))) {
- ause += countint(key2tval(n), nums);
- totaluse++;
- }
+ Node *n = &t->node[i];
+ if (!ttisfree(gval(n))) {
+ ause += countint(key2tval(n), nums);
+ totaluse++;
+ }
}
*pnasize += ause;
return totaluse;
@@ -283,7 +283,7 @@ static void setarrayvector (klisp_State *K, Table *t, int32_t size)
int32_t i;
klispM_reallocvector(K, t->array, t->sizearray, size, TValue);
for (i=t->sizearray; i<size; i++)
- t->array[i] = KFREE;
+ t->array[i] = KFREE;
t->sizearray = size;
}
@@ -292,22 +292,22 @@ static void setnodevector (klisp_State *K, Table *t, int32_t size)
{
int32_t lsize;
if (size == 0) { /* no elements to hash part? */
- t->node = cast(Node *, dummynode); /* use common `dummynode' */
- lsize = 0;
+ t->node = cast(Node *, dummynode); /* use common `dummynode' */
+ lsize = 0;
}
else {
- int32_t i;
- lsize = ceillog2(size);
- if (lsize > MAXBITS)
- klispE_throw_simple(K, "table overflow");
- size = twoto(lsize);
- t->node = klispM_newvector(K, size, Node);
- for (i=0; i<size; i++) {
- Node *n = gnode(t, i);
- gnext(n) = NULL;
- gkey(n)->this = KFREE;
- gval(n) = KFREE;
- }
+ int32_t i;
+ lsize = ceillog2(size);
+ if (lsize > MAXBITS)
+ klispE_throw_simple(K, "table overflow");
+ size = twoto(lsize);
+ t->node = klispM_newvector(K, size, Node);
+ for (i=0; i<size; i++) {
+ Node *n = gnode(t, i);
+ gnext(n) = NULL;
+ gkey(n)->this = KFREE;
+ gval(n) = KFREE;
+ }
}
t->lsizenode = (uint8_t) (lsize);
t->lastfree = gnode(t, size); /* all positions are free */
@@ -321,33 +321,33 @@ static void resize (klisp_State *K, Table *t, int32_t nasize, int32_t nhsize)
int32_t oldhsize = t->lsizenode;
Node *nold = t->node; /* save old hash ... */
if (nasize > oldasize) /* array part must grow? */
- setarrayvector(K, t, nasize);
+ setarrayvector(K, t, nasize);
/* create new hash part with appropriate size */
setnodevector(K, t, nhsize);
if (nasize < oldasize) { /* array part must shrink? */
- t->sizearray = nasize;
- /* re-insert elements from vanishing slice */
- for (i=nasize; i<oldasize; i++) {
- if (!ttisfree(t->array[i])) {
- TValue v = t->array[i];
- *klispH_setfixint(K, t, i) = v;
- checkliveness(K, v);
- }
- }
- /* shrink array */
- klispM_reallocvector(K, t->array, oldasize, nasize, TValue);
+ t->sizearray = nasize;
+ /* re-insert elements from vanishing slice */
+ for (i=nasize; i<oldasize; i++) {
+ if (!ttisfree(t->array[i])) {
+ TValue v = t->array[i];
+ *klispH_setfixint(K, t, i) = v;
+ checkliveness(K, v);
+ }
+ }
+ /* shrink array */
+ klispM_reallocvector(K, t->array, oldasize, nasize, TValue);
}
/* re-insert elements from hash part */
for (i = twoto(oldhsize) - 1; i >= 0; i--) {
- Node *old = nold+i;
- if (!ttisfree(gval(old))) {
- TValue v = gval(old);
- *klispH_set(K, t, key2tval(old)) = v;
- checkliveness(K, v);
- }
+ Node *old = nold+i;
+ if (!ttisfree(gval(old))) {
+ TValue v = gval(old);
+ *klispH_set(K, t, key2tval(old)) = v;
+ checkliveness(K, v);
+ }
}
if (nold != dummynode)
- klispM_freearray(K, nold, twoto(oldhsize), Node); /* free old array */
+ klispM_freearray(K, nold, twoto(oldhsize), Node); /* free old array */
}
@@ -384,10 +384,10 @@ static void rehash (klisp_State *K, Table *t, const TValue ek) {
/* wflags should be either or both of K_FLAG_WEAK_KEYS or K_FLAG_WEAK VALUES */
TValue klispH_new (klisp_State *K, int32_t narray, int32_t nhash,
- int32_t wflags)
+ int32_t wflags)
{
klisp_assert((wflags & (K_FLAG_WEAK_KEYS | K_FLAG_WEAK_VALUES)) ==
- wflags);
+ wflags);
Table *t = klispM_new(K, Table);
klispC_link(K, (GCObject *) t, K_TTABLE, wflags);
/* temporary values (kept only if some malloc fails) */
@@ -409,7 +409,7 @@ TValue klispH_new (klisp_State *K, int32_t narray, int32_t nhash,
void klispH_free (klisp_State *K, Table *t)
{
if (t->node != dummynode)
- klispM_freearray(K, t->node, sizenode(t), Node);
+ klispM_freearray(K, t->node, sizenode(t), Node);
klispM_freearray(K, t->array, t->sizearray, TValue);
klispM_free(K, t);
}
@@ -418,8 +418,8 @@ void klispH_free (klisp_State *K, Table *t)
static Node *getfreepos (Table *t)
{
while (t->lastfree-- > t->node) {
- if (ttisfree(gkey(t->lastfree)->this))
- return t->lastfree;
+ if (ttisfree(gkey(t->lastfree)->this))
+ return t->lastfree;
}
return NULL; /* could not find a free place */
}
@@ -436,27 +436,27 @@ static TValue *newkey (klisp_State *K, Table *t, TValue key)
{
Node *mp = mainposition(t, key);
if (!ttisfree(gval(mp)) || mp == dummynode) {
- Node *othern;
- Node *n = getfreepos(t); /* get a free place */
- if (n == NULL) { /* cannot find a free place? */
- rehash(K, t, key); /* grow table */
- return klispH_set(K, t, key); /* re-insert key into grown table */
- }
- klisp_assert(n != dummynode);
- othern = mainposition(t, key2tval(mp));
- if (othern != mp) { /* is colliding node out of its main position? */
- /* yes; move colliding node into free position */
- while (gnext(othern) != mp) othern = gnext(othern); /* find previous */
- gnext(othern) = n; /* redo the chain with `n' in place of `mp' */
- *n = *mp; /* copy colliding node into free pos. (mp->next also goes) */
- gnext(mp) = NULL; /* now `mp' is free */
- gval(mp) = KFREE;
- } else { /* colliding node is in its own main position */
- /* new node will go into free position */
- gnext(n) = gnext(mp); /* chain new position */
- gnext(mp) = n;
- mp = n;
- }
+ Node *othern;
+ Node *n = getfreepos(t); /* get a free place */
+ if (n == NULL) { /* cannot find a free place? */
+ rehash(K, t, key); /* grow table */
+ return klispH_set(K, t, key); /* re-insert key into grown table */
+ }
+ klisp_assert(n != dummynode);
+ othern = mainposition(t, key2tval(mp));
+ if (othern != mp) { /* is colliding node out of its main position? */
+ /* yes; move colliding node into free position */
+ while (gnext(othern) != mp) othern = gnext(othern); /* find previous */
+ gnext(othern) = n; /* redo the chain with `n' in place of `mp' */
+ *n = *mp; /* copy colliding node into free pos. (mp->next also goes) */
+ gnext(mp) = NULL; /* now `mp' is free */
+ gval(mp) = KFREE;
+ } else { /* colliding node is in its own main position */
+ /* new node will go into free position */
+ gnext(n) = gnext(mp); /* chain new position */
+ gnext(mp) = n;
+ mp = n;
+ }
}
gkey(mp)->this = key;
klispC_barriert(K, t, key);
@@ -471,15 +471,15 @@ static TValue *newkey (klisp_State *K, Table *t, TValue key)
const TValue *klispH_getfixint (Table *t, int32_t key)
{
if (key >= 0 && key < t->sizearray)
- return &t->array[key];
+ return &t->array[key];
else {
- Node *n = hashfixint(t, key);
- do { /* check whether `key' is somewhere in the chain */
- if (ttisfixint(gkey(n)->this) && ivalue(gkey(n)->this) == key)
- return &gval(n); /* that's it */
- else n = gnext(n);
- } while (n);
- return &kfree;
+ Node *n = hashfixint(t, key);
+ do { /* check whether `key' is somewhere in the chain */
+ if (ttisfixint(gkey(n)->this) && ivalue(gkey(n)->this) == key)
+ return &gval(n); /* that's it */
+ else n = gnext(n);
+ } while (n);
+ return &kfree;
}
}
@@ -491,9 +491,9 @@ const TValue *klispH_getstr (Table *t, String *key) {
klisp_assert(kstring_immutablep(gc2str(key)));
Node *n = hashstr(t, key);
do { /* check whether `key' is somewhere in the chain */
- if (ttisstring(gkey(n)->this) && tv2str(gkey(n)->this) == key)
- return &gval(n); /* that's it */
- else n = gnext(n);
+ if (ttisstring(gkey(n)->this) && tv2str(gkey(n)->this) == key)
+ return &gval(n); /* that's it */
+ else n = gnext(n);
} while (n);
return &kfree;
}
@@ -505,10 +505,10 @@ const TValue *klispH_getsym (Table *t, Symbol *key) {
Node *n = hashsym(t, key);
TValue tv_key = gc2sym(key);
do { /* check whether `key' is somewhere in the chain */
- if (ttissymbol(gkey(n)->this) &&
- tv_sym_equal(gkey(n)->this, tv_key))
- return &gval(n); /* that's it */
- else n = gnext(n);
+ if (ttissymbol(gkey(n)->this) &&
+ tv_sym_equal(gkey(n)->this, tv_key))
+ return &gval(n); /* that's it */
+ else n = gnext(n);
} while (n);
return &kfree;
}
@@ -524,19 +524,19 @@ const TValue *klispH_get (Table *t, TValue key)
case K_TSYMBOL: return klispH_getsym(t, tv2sym(key));
case K_TFIXINT: return klispH_getfixint(t, ivalue(key));
case K_TSTRING:
- if (kstring_immutablep(key))
- return klispH_getstr(t, tv2str(key));
- /* else fall through */
+ if (kstring_immutablep(key))
+ return klispH_getstr(t, tv2str(key));
+ /* else fall through */
default: {
- Node *n = mainposition(t, key);
- do { /* check whether `key' is somewhere in the chain */
- /* XXX: for some reason eq2p takes klisp_State but
- doesn't use it */
- if (eq2p((klisp_State *)NULL, key2tval(n), key))
- return &gval(n); /* that's it */
- else n = gnext(n);
- } while (n);
- return &kfree;
+ Node *n = mainposition(t, key);
+ do { /* check whether `key' is somewhere in the chain */
+ /* XXX: for some reason eq2p takes klisp_State but
+ doesn't use it */
+ if (eq2p((klisp_State *)NULL, key2tval(n), key))
+ return &gval(n); /* that's it */
+ else n = gnext(n);
+ } while (n);
+ return &kfree;
}
}
}
@@ -546,15 +546,15 @@ TValue *klispH_set (klisp_State *K, Table *t, TValue key)
{
const TValue *p = klispH_get(t, key);
if (p != &kfree)
- return cast(TValue *, p);
+ return cast(TValue *, p);
else {
- if (ttisfree(key))
- klispE_throw_simple(K, "table index is free");
+ if (ttisfree(key))
+ klispE_throw_simple(K, "table index is free");
/*
else if (ttisnumber(key) && luai_numisnan(nvalue(key)))
luaG_runerror(L, "table index is NaN");
*/
- return newkey(K, t, key);
+ return newkey(K, t, key);
}
}
@@ -563,9 +563,9 @@ TValue *klispH_setfixint (klisp_State *K, Table *t, int32_t key)
{
const TValue *p = klispH_getfixint(t, key);
if (p != &kfree)
- return cast(TValue *, p);
+ return cast(TValue *, p);
else
- return newkey(K, t, i2tv(key));
+ return newkey(K, t, i2tv(key));
}
@@ -574,9 +574,9 @@ TValue *klispH_setstr (klisp_State *K, Table *t, String *key)
klisp_assert(kstring_immutablep(gc2str(key)));
const TValue *p = klispH_getstr(t, key);
if (p != &kfree)
- return cast(TValue *, p);
+ return cast(TValue *, p);
else {
- return newkey(K, t, gc2str(key));
+ return newkey(K, t, gc2str(key));
}
}
@@ -585,36 +585,36 @@ TValue *klispH_setsym (klisp_State *K, Table *t, Symbol *key)
{
const TValue *p = klispH_getsym(t, key);
if (p != &kfree)
- return cast(TValue *, p);
+ return cast(TValue *, p);
else {
- return newkey(K, t, gc2sym(key));
+ return newkey(K, t, gc2sym(key));
}
}
/* klisp: Untested, may have off by one errors, check before using */
static int32_t unbound_search (Table *t, int32_t j) {
- int32_t i = j; /* i -1 or a present index */
- j++;
- /* find `i' and `j' such that i is present and j is not */
- while (!ttisfree(*klispH_getfixint(t, j))) {
- i = j;
- if (j <= (INT32_MAX - i) / 2)
- j *= 2;
- else { /* overflow? */
- /* table was built with bad purposes: resort to linear search */
- i = 0;
- while (!ttisfree(*klispH_getfixint(t, i))) i++;
- return i-1;
+ int32_t i = j; /* i -1 or a present index */
+ j++;
+ /* find `i' and `j' such that i is present and j is not */
+ while (!ttisfree(*klispH_getfixint(t, j))) {
+ i = j;
+ if (j <= (INT32_MAX - i) / 2)
+ j *= 2;
+ else { /* overflow? */
+ /* table was built with bad purposes: resort to linear search */
+ i = 0;
+ while (!ttisfree(*klispH_getfixint(t, i))) i++;
+ return i-1;
+ }
+ }
+ /* now do a binary search between them */
+ while (j - i > 1) {
+ int32_t m = (i+j)/2;
+ if (ttisfree(*klispH_getfixint(t, m))) j = m;
+ else i = m;
}
- }
- /* now do a binary search between them */
- while (j - i > 1) {
- int32_t m = (i+j)/2;
- if (ttisfree(*klispH_getfixint(t, m))) j = m;
- else i = m;
- }
- return i;
+ return i;
}
@@ -627,17 +627,17 @@ static int32_t unbound_search (Table *t, int32_t j) {
int32_t klispH_getn (Table *t) {
int32_t j = t->sizearray - 1;
if (j >= 0 && ttisfree(t->array[j])) {
- /* there is a boundary in the array part: (binary) search for it */
- int32_t i = -1;
- while (j - i > 1) {
- int32_t m = (i+j)/2;
- if (ttisfree(t->array[m])) j = m;
- else i = m;
- }
- return i;
+ /* there is a boundary in the array part: (binary) search for it */
+ int32_t i = -1;
+ while (j - i > 1) {
+ int32_t m = (i+j)/2;
+ if (ttisfree(t->array[m])) j = m;
+ else i = m;
+ }
+ return i;
}
/* else must find a boundary in hash part */
else if (t->node == dummynode) /* hash part is empty? */
- return j; /* that is easy... */
+ return j; /* that is easy... */
else return unbound_search(t, j);
}
diff --git a/src/ktable.h b/src/ktable.h
@@ -31,7 +31,7 @@ TValue *klispH_setsym (klisp_State *K, Table *t, Symbol *key);
const TValue *klispH_get (Table *t, TValue key);
TValue *klispH_set (klisp_State *K, Table *t, TValue key);
TValue klispH_new (klisp_State *K, int32_t narray, int32_t nhash,
- int32_t wflags);
+ int32_t wflags);
void klispH_resizearray (klisp_State *K, Table *t, int32_t nasize);
void klispH_free (klisp_State *K, Table *t);
int32_t klispH_next (klisp_State *K, Table *t, TValue *key, TValue *data);
diff --git a/src/ktoken.c b/src/ktoken.c
@@ -47,7 +47,7 @@ void kcharset_union(kcharset, kcharset);
void kcharset_empty(kcharset chs)
{
for (int i = 0; i < 8; i++) {
- chs[i] = 0;
+ chs[i] = 0;
}
}
@@ -59,14 +59,14 @@ void kcharset_fill(kcharset chs, char *chars_)
kcharset_empty(chs);
while ((ch = *chars++)) {
- chs[KCHS_OCTANT(ch)] |= KCHS_BIT(ch);
+ chs[KCHS_OCTANT(ch)] |= KCHS_BIT(ch);
}
}
void kcharset_union(kcharset chs, kcharset chs2)
{
for (int i = 0; i < 8; i++) {
- chs[i] |= chs2[i];
+ chs[i] |= chs2[i];
}
}
@@ -101,7 +101,7 @@ void ktok_init(klisp_State *K)
{
/* Character sets */
kcharset_fill(ktok_alphabetic, "ABCDEFGHIJKLMNOPQRSTUVWXYZ"
- "abcdefghijklmnopqrstuvwxyz");
+ "abcdefghijklmnopqrstuvwxyz");
kcharset_fill(ktok_numeric, "0123456789");
/* keep synchronized with cases in main tokenizer switch */
kcharset_fill(ktok_whitespace, " \t\v\r\n\f");
@@ -144,17 +144,17 @@ void ktok_error_g(klisp_State *K, char *str, bool extra, TValue extra_value)
/* save the last source code info on the port */
kport_update_source_info(K->curr_port, K->ktok_source_info.line,
- K->ktok_source_info.col);
+ K->ktok_source_info.col);
/* include the source info (and extra value if present) in the error */
TValue irritants;
if (extra) {
- krooted_tvs_push(K, extra_value); /* will be popped by throw */
- TValue si = ktok_get_source_info(K);
- krooted_tvs_push(K, si); /* will be popped by throw */
- irritants = klist_g(K, false, 2, si, extra_value);
+ krooted_tvs_push(K, extra_value); /* will be popped by throw */
+ TValue si = ktok_get_source_info(K);
+ krooted_tvs_push(K, si); /* will be popped by throw */
+ irritants = klist_g(K, false, 2, si, extra_value);
} else {
- irritants = ktok_get_source_info(K);
+ irritants = ktok_get_source_info(K);
}
krooted_tvs_push(K, irritants); /* will be popped by throw */
klispE_throw_with_irritants(K, str, irritants);
@@ -171,48 +171,48 @@ int ktok_ggetc(klisp_State *K)
{
/* XXX when full unicode is used (uint32_t) a different way should
be use to signal EOF */
-
+
TValue port = K->curr_port;
if (ttisfport(port)) {
- /* fport */
- FILE *file = kfport_file(port);
- int chi = getc(file);
- if (chi == EOF) {
- /* NOTE: eof doesn't change source code location info */
- if (ferror(file) != 0) {
- /* clear error marker to allow retries later */
- clearerr(file);
+ /* fport */
+ FILE *file = kfport_file(port);
+ int chi = getc(file);
+ if (chi == EOF) {
+ /* NOTE: eof doesn't change source code location info */
+ if (ferror(file) != 0) {
+ /* clear error marker to allow retries later */
+ clearerr(file);
/* TODO put error info on the error obj */
- ktok_error(K, "reading error");
- return 0;
- } else { /* if (feof(file) != 0) */
- /* let the eof marker set */
- K->ktok_seen_eof = true;
- return EOF;
- }
- } else
- return chi;
+ ktok_error(K, "reading error");
+ return 0;
+ } else { /* if (feof(file) != 0) */
+ /* let the eof marker set */
+ K->ktok_seen_eof = true;
+ return EOF;
+ }
+ } else
+ return chi;
} else {
- /* mport */
- if (kport_is_binary(port)) {
- /* bytevector port */
- if (kmport_off(port) >= kbytevector_size(kmport_buf(port))) {
- K->ktok_seen_eof = true;
- return EOF;
- }
- int chi = kbytevector_buf(kmport_buf(port))[kmport_off(port)];
- ++kmport_off(port);
- return chi;
- } else {
- /* string port */
- if (kmport_off(port) >= kstring_size(kmport_buf(port))) {
- K->ktok_seen_eof = true;
- return EOF;
- }
- int chi = kstring_buf(kmport_buf(port))[kmport_off(port)];
- ++kmport_off(port);
- return chi;
- }
+ /* mport */
+ if (kport_is_binary(port)) {
+ /* bytevector port */
+ if (kmport_off(port) >= kbytevector_size(kmport_buf(port))) {
+ K->ktok_seen_eof = true;
+ return EOF;
+ }
+ int chi = kbytevector_buf(kmport_buf(port))[kmport_off(port)];
+ ++kmport_off(port);
+ return chi;
+ } else {
+ /* string port */
+ if (kmport_off(port) >= kstring_size(kmport_buf(port))) {
+ K->ktok_seen_eof = true;
+ return EOF;
+ }
+ int chi = kstring_buf(kmport_buf(port))[kmport_off(port)];
+ ++kmport_off(port);
+ return chi;
+ }
}
}
@@ -220,61 +220,61 @@ int ktok_ggetc(klisp_State *K)
void ktok_gungetc(klisp_State *K, int chi)
{
if (chi == EOF)
- return;
+ return;
TValue port = K->curr_port;
if (ttisfport(port)) {
- /* fport */
- FILE *file = kfport_file(port);
-
- if (ungetc(chi, file) == EOF) {
- if (ferror(file) != 0) {
- /* clear error marker to allow retries later */
- clearerr(file);
- }
- /* TODO put error info on the error obj */
- ktok_error(K, "reading error");
- return;
- }
+ /* fport */
+ FILE *file = kfport_file(port);
+
+ if (ungetc(chi, file) == EOF) {
+ if (ferror(file) != 0) {
+ /* clear error marker to allow retries later */
+ clearerr(file);
+ }
+ /* TODO put error info on the error obj */
+ ktok_error(K, "reading error");
+ return;
+ }
} else {
- /* mport */
- if (kport_is_binary(port)) {
- /* bytevector port */
- --kmport_off(port);
- } else {
- /* string port */
- --kmport_off(port);
- }
+ /* mport */
+ if (kport_is_binary(port)) {
+ /* bytevector port */
+ --kmport_off(port);
+ } else {
+ /* string port */
+ --kmport_off(port);
+ }
}
}
int ktok_peekc_getc(klisp_State *K, bool peekp)
{
/* WORKAROUND: for stdin line buffering & reading of EOF, this flag
- is reset on every read */
+ is reset on every read */
/* Otherwise, at least in linux, after reading or peeking an EOF from the
console, the next char isn't eof anymore */
if (K->ktok_seen_eof)
- return EOF;
+ return EOF;
int chi = ktok_ggetc(K);
if (peekp) {
- ktok_gungetc(K, chi);
- return chi;
+ ktok_gungetc(K, chi);
+ return chi;
}
/* track source code location before returning the char */
if (chi == '\t') {
- /* align column to next tab stop */
- K->ktok_source_info.col =
- (K->ktok_source_info.col + K->ktok_source_info.tab_width) -
- (K->ktok_source_info.col % K->ktok_source_info.tab_width);
+ /* align column to next tab stop */
+ K->ktok_source_info.col =
+ (K->ktok_source_info.col + K->ktok_source_info.tab_width) -
+ (K->ktok_source_info.col % K->ktok_source_info.tab_width);
} else if (chi == '\n') {
- K->ktok_source_info.line++;
- K->ktok_source_info.col = 0;
+ K->ktok_source_info.line++;
+ K->ktok_source_info.col = 0;
} else {
- K->ktok_source_info.col++;
+ K->ktok_source_info.col++;
}
return chi;
}
@@ -289,7 +289,7 @@ TValue ktok_get_source_info(klisp_State *K)
{
/* TEMP: for now, lines and column names are fixints */
TValue pos = kcons(K, i2tv(K->ktok_source_info.saved_line),
- i2tv(K->ktok_source_info.saved_col));
+ i2tv(K->ktok_source_info.saved_col));
krooted_tvs_push(K, pos);
/* the filename is rooted in the port */
TValue res = kcons(K, K->ktok_source_info.filename, pos);
@@ -298,7 +298,7 @@ TValue ktok_get_source_info(klisp_State *K)
}
void ktok_set_source_info(klisp_State *K, TValue filename, int32_t line,
- int32_t col)
+ int32_t col)
{
K->ktok_source_info.filename = filename;
K->ktok_source_info.line = line;
@@ -317,8 +317,8 @@ char ktok_read_hex_escape(klisp_State *K);
TValue ktok_read_string(klisp_State *K);
TValue ktok_read_special(klisp_State *K);
TValue ktok_read_number(klisp_State *K, char *buf, int32_t len,
- bool has_exactp, bool exactp, bool has_radixp,
- int32_t radix);
+ bool has_exactp, bool exactp, bool has_radixp,
+ int32_t radix);
TValue ktok_read_maybe_signed_numeric(klisp_State *K);
TValue ktok_read_identifier_or_dot(klisp_State *K, bool keywordp);
TValue ktok_read_bar_identifier(klisp_State *K, bool keywordp);
@@ -332,123 +332,123 @@ TValue ktok_read_token(klisp_State *K)
klisp_assert(ks_tbisempty(K));
while(true) {
- /* save the source info in case a token starts here */
- ktok_save_source_info(K);
-
- int chi = ktok_peekc(K);
-
- switch(chi) {
- case EOF:
- ktok_getc(K);
- return KEOF;
- case ' ':
- case '\n':
- case '\r':
- case '\t':
- case '\v':
- case '\f': /* Keep synchronized with whitespace chars */
- ktok_ignore_whitespace(K);
- continue;
- case ';':
- ktok_ignore_single_line_comment(K);
- continue;
- case '(':
- ktok_getc(K);
- return K->ktok_lparen;
- case ')':
- ktok_getc(K);
- return K->ktok_rparen;
- case '"':
- return ktok_read_string(K);
- case '|':
- return ktok_read_bar_identifier(K, false);
+ /* save the source info in case a token starts here */
+ ktok_save_source_info(K);
+
+ int chi = ktok_peekc(K);
+
+ switch(chi) {
+ case EOF:
+ ktok_getc(K);
+ return KEOF;
+ case ' ':
+ case '\n':
+ case '\r':
+ case '\t':
+ case '\v':
+ case '\f': /* Keep synchronized with whitespace chars */
+ ktok_ignore_whitespace(K);
+ continue;
+ case ';':
+ ktok_ignore_single_line_comment(K);
+ continue;
+ case '(':
+ ktok_getc(K);
+ return K->ktok_lparen;
+ case ')':
+ ktok_getc(K);
+ return K->ktok_rparen;
+ case '"':
+ return ktok_read_string(K);
+ case '|':
+ return ktok_read_bar_identifier(K, false);
/* TODO use read_until_delimiter in all these cases */
- case '#': {
- ktok_getc(K);
- chi = ktok_peekc(K);
- switch(chi) {
- case EOF:
- ktok_error(K, "# constant is too short");
- return KINERT; /* avoid warning */
- case '!': /* single line comment (alternative syntax) */
- /* this handles the #! style script header too! */
- ktok_ignore_single_line_comment(K);
- continue;
- case '|': /* nested/multiline comment */
- ktok_getc(K); /* discard the '|' */
- klisp_assert(K->ktok_nested_comments == 0);
- K->ktok_nested_comments = 1;
- ktok_ignore_multi_line_comment(K);
- continue;
- case ';': /* sexp comment */
- ktok_getc(K); /* discard the ';' */
- return K->ktok_sexp_comment;
- case ':': /* keyword */
- ktok_getc(K); /* discard the ':' */
- chi = ktok_peekc(K);
- if (chi == EOF) {
- ktok_error(K, "# constant is too short");
- return KINERT; /* avoid warning */
- } else if (chi == '|') {
- return ktok_read_bar_identifier(K, true);
- } else if (chi == '\\' || ktok_is_initial(chi)) {
- return ktok_read_identifier_or_dot(K, true);
- } else if (chi == '+' || chi == '-') {
- char ch = (char) chi;
- ktok_getc(K); /* discard the '+' or '-' */
- if (ktok_check_delimiter(K)) {
- return kkeyword_new_bs(K, &ch, 1);
- } else {
- ktok_error_extra(K, "invalid start in keyword",
- ch2tv(ch));
- return KINERT; /* avoid warning */
- }
- } else {
- ktok_error_extra(K, "invalid char starting keyword",
- ch2tv((char) chi));
- return KINERT; /* avoid warning */
- }
- default:
- return ktok_read_special(K);
- }
- }
- case '0': case '1': case '2': case '3': case '4':
- case '5': case '6': case '7': case '8': case '9': {
- /* positive number, no exactness or radix indicator */
- int32_t buf_len = ktok_read_until_delimiter(K);
- char *buf = ks_tbget_buffer(K);
- /* read number should free the tbbuffer */
- return ktok_read_number(K, buf, buf_len, false, false, false, 10);
- }
- case '+': case '-':
- /* signed number, no exactness or radix indicator */
- return ktok_read_maybe_signed_numeric(K);
- case '\\': /* this is a symbol that starts with an hex escape */
- /* These should be kept synchronized with initial */
- case 'A': case 'B': case 'C': case 'D': case 'E': case 'F': case 'G':
- case 'H': case 'I': case 'J': case 'K': case 'L': case 'M': case 'N':
- case 'O': case 'P': case 'Q': case 'R': case 'S': case 'T': case 'U':
- case 'V': case 'W': case 'X': case 'Y': case 'Z':
- case 'a': case 'b': case 'c': case 'd': case 'e': case 'f': case 'g':
- case 'h': case 'i': case 'j': case 'k': case 'l': case 'm': case 'n':
- case 'o': case 'p': case 'q': case 'r': case 's': case 't': case 'u':
- case 'v': case 'w': case 'x': case 'y': case 'z':
- case '!': case '$': case '%': case '&': case '*': case '/': case ':':
- case '<': case '=': case '>': case '?': case '@': case '^': case '_':
- case '~':
- case '.': /* this is either a symbol or a dot token */
- /*
- ** N.B.: the cases for '+', and '-', were already
- ** considered
- */
- return ktok_read_identifier_or_dot(K, false);
- default:
- chi = ktok_getc(K);
- ktok_error_extra(K, "unrecognized token starting char",
- ch2tv((char) chi));
- /* avoid warning */
- return KINERT;
- }
+ case '#': {
+ ktok_getc(K);
+ chi = ktok_peekc(K);
+ switch(chi) {
+ case EOF:
+ ktok_error(K, "# constant is too short");
+ return KINERT; /* avoid warning */
+ case '!': /* single line comment (alternative syntax) */
+ /* this handles the #! style script header too! */
+ ktok_ignore_single_line_comment(K);
+ continue;
+ case '|': /* nested/multiline comment */
+ ktok_getc(K); /* discard the '|' */
+ klisp_assert(K->ktok_nested_comments == 0);
+ K->ktok_nested_comments = 1;
+ ktok_ignore_multi_line_comment(K);
+ continue;
+ case ';': /* sexp comment */
+ ktok_getc(K); /* discard the ';' */
+ return K->ktok_sexp_comment;
+ case ':': /* keyword */
+ ktok_getc(K); /* discard the ':' */
+ chi = ktok_peekc(K);
+ if (chi == EOF) {
+ ktok_error(K, "# constant is too short");
+ return KINERT; /* avoid warning */
+ } else if (chi == '|') {
+ return ktok_read_bar_identifier(K, true);
+ } else if (chi == '\\' || ktok_is_initial(chi)) {
+ return ktok_read_identifier_or_dot(K, true);
+ } else if (chi == '+' || chi == '-') {
+ char ch = (char) chi;
+ ktok_getc(K); /* discard the '+' or '-' */
+ if (ktok_check_delimiter(K)) {
+ return kkeyword_new_bs(K, &ch, 1);
+ } else {
+ ktok_error_extra(K, "invalid start in keyword",
+ ch2tv(ch));
+ return KINERT; /* avoid warning */
+ }
+ } else {
+ ktok_error_extra(K, "invalid char starting keyword",
+ ch2tv((char) chi));
+ return KINERT; /* avoid warning */
+ }
+ default:
+ return ktok_read_special(K);
+ }
+ }
+ case '0': case '1': case '2': case '3': case '4':
+ case '5': case '6': case '7': case '8': case '9': {
+ /* positive number, no exactness or radix indicator */
+ int32_t buf_len = ktok_read_until_delimiter(K);
+ char *buf = ks_tbget_buffer(K);
+ /* read number should free the tbbuffer */
+ return ktok_read_number(K, buf, buf_len, false, false, false, 10);
+ }
+ case '+': case '-':
+ /* signed number, no exactness or radix indicator */
+ return ktok_read_maybe_signed_numeric(K);
+ case '\\': /* this is a symbol that starts with an hex escape */
+ /* These should be kept synchronized with initial */
+ case 'A': case 'B': case 'C': case 'D': case 'E': case 'F': case 'G':
+ case 'H': case 'I': case 'J': case 'K': case 'L': case 'M': case 'N':
+ case 'O': case 'P': case 'Q': case 'R': case 'S': case 'T': case 'U':
+ case 'V': case 'W': case 'X': case 'Y': case 'Z':
+ case 'a': case 'b': case 'c': case 'd': case 'e': case 'f': case 'g':
+ case 'h': case 'i': case 'j': case 'k': case 'l': case 'm': case 'n':
+ case 'o': case 'p': case 'q': case 'r': case 's': case 't': case 'u':
+ case 'v': case 'w': case 'x': case 'y': case 'z':
+ case '!': case '$': case '%': case '&': case '*': case '/': case ':':
+ case '<': case '=': case '>': case '?': case '@': case '^': case '_':
+ case '~':
+ case '.': /* this is either a symbol or a dot token */
+ /*
+ ** N.B.: the cases for '+', and '-', were already
+ ** considered
+ */
+ return ktok_read_identifier_or_dot(K, false);
+ default:
+ chi = ktok_getc(K);
+ ktok_error_extra(K, "unrecognized token starting char",
+ ch2tv((char) chi));
+ /* avoid warning */
+ return KINERT;
+ }
}
}
@@ -459,7 +459,7 @@ void ktok_ignore_single_line_comment(klisp_State *K)
{
int chi;
do {
- chi = ktok_getc(K);
+ chi = ktok_getc(K);
} while (chi != EOF && chi != '\n');
}
@@ -473,41 +473,41 @@ void ktok_ignore_multi_line_comment(klisp_State *K)
ks_spush(K, KNIL);
while(K->ktok_nested_comments > 0) {
- chi = ktok_peekc(K);
- while (chi != EOF && chi != '|' && chi != '#') {
- UNUSED(ktok_getc(K));
- chi = ktok_peekc(K);
- }
- if (chi == EOF)
- goto eof_error;
-
- char first_char = (char) chi;
-
- /* this first char will actually be the same just peeked, that's no
- problem, it will save the source info the first time around the
- loop */
- chi = ktok_peekc(K);
- while (chi != EOF && chi == first_char) {
- ktok_save_source_info(K);
- UNUSED(ktok_getc(K));
- chi = ktok_peekc(K);
- }
- if (chi == EOF)
- goto eof_error;
-
- UNUSED(ktok_getc(K));
-
- if (chi == '#') {
- /* close comment (first char was '|', so the seq is "|#") */
- --K->ktok_nested_comments;
- last_nested_comment_si = ks_spop(K);
- } else if (chi == '|') {
- /* open comment (first char was '#', so the seq is "#|") */
- klisp_assert(K->ktok_nested_comments < 1000);
- ++K->ktok_nested_comments;
- ks_spush(K, last_nested_comment_si);
- last_nested_comment_si = ktok_get_source_info(K);
- }
+ chi = ktok_peekc(K);
+ while (chi != EOF && chi != '|' && chi != '#') {
+ UNUSED(ktok_getc(K));
+ chi = ktok_peekc(K);
+ }
+ if (chi == EOF)
+ goto eof_error;
+
+ char first_char = (char) chi;
+
+ /* this first char will actually be the same just peeked, that's no
+ problem, it will save the source info the first time around the
+ loop */
+ chi = ktok_peekc(K);
+ while (chi != EOF && chi == first_char) {
+ ktok_save_source_info(K);
+ UNUSED(ktok_getc(K));
+ chi = ktok_peekc(K);
+ }
+ if (chi == EOF)
+ goto eof_error;
+
+ UNUSED(ktok_getc(K));
+
+ if (chi == '#') {
+ /* close comment (first char was '|', so the seq is "|#") */
+ --K->ktok_nested_comments;
+ last_nested_comment_si = ks_spop(K);
+ } else if (chi == '|') {
+ /* open comment (first char was '#', so the seq is "#|") */
+ klisp_assert(K->ktok_nested_comments < 1000);
+ ++K->ktok_nested_comments;
+ ks_spush(K, last_nested_comment_si);
+ last_nested_comment_si = ktok_get_source_info(K);
+ }
/* else lone '#' or '|', just continue */
}
krooted_vars_pop(K);
@@ -524,18 +524,18 @@ void ktok_ignore_whitespace(klisp_State *K)
{
/* NOTE: if it's not whitespace do nothing (even on eof) */
while(true) {
- int chi = ktok_peekc(K);
-
- if (chi == EOF) {
- return;
- } else {
- char ch = (char) chi;
- if (ktok_is_whitespace(ch)) {
- ktok_getc(K);
- } else {
- return;
- }
- }
+ int chi = ktok_peekc(K);
+
+ if (chi == EOF) {
+ return;
+ } else {
+ char ch = (char) chi;
+ if (ktok_is_whitespace(ch)) {
+ ktok_getc(K);
+ } else {
+ return;
+ }
+ }
}
}
@@ -556,10 +556,10 @@ int32_t ktok_read_until_delimiter(klisp_State *K)
int i = 0;
while (!ktok_check_delimiter(K)) {
- /* NOTE: can't be eof, because eof is a delimiter */
- char ch = (char) ktok_getc(K);
- ks_tbadd(K, ch);
- i++;
+ /* NOTE: can't be eof, because eof is a delimiter */
+ char ch = (char) ktok_getc(K);
+ ks_tbadd(K, ch);
+ i++;
}
ks_tbadd(K, '\0');
return i;
@@ -572,37 +572,37 @@ int32_t ktok_read_until_delimiter(klisp_State *K)
** len should be at least one
*/
TValue ktok_read_number(klisp_State *K, char *buf, int32_t len,
- bool has_exactp, bool exactp, bool has_radixp,
- int32_t radix)
+ bool has_exactp, bool exactp, bool has_radixp,
+ int32_t radix)
{
UNUSED(len); /* not needed really, buf ends with '\0' */
TValue n;
if (radix == 10) {
- /* only allow decimals with radix 10 */
- bool decimalp = false;
- if (!krational_read_decimal(K, buf, radix, &n, NULL, &decimalp)) {
- /* TODO throw meaningful error msgs, use last param */
- ktok_error(K, "Bad format in number");
- return KINERT;
- }
- if (decimalp && !has_exactp) {
- /* handle decimal format as an explicit #i */
- has_exactp = true;
- exactp = false;
- }
+ /* only allow decimals with radix 10 */
+ bool decimalp = false;
+ if (!krational_read_decimal(K, buf, radix, &n, NULL, &decimalp)) {
+ /* TODO throw meaningful error msgs, use last param */
+ ktok_error(K, "Bad format in number");
+ return KINERT;
+ }
+ if (decimalp && !has_exactp) {
+ /* handle decimal format as an explicit #i */
+ has_exactp = true;
+ exactp = false;
+ }
} else {
- if (!krational_read(K, buf, radix, &n, NULL)) {
- /* TODO throw meaningful error msgs, use last param */
- ktok_error(K, "Bad format in number");
- return KINERT;
- }
+ if (!krational_read(K, buf, radix, &n, NULL)) {
+ /* TODO throw meaningful error msgs, use last param */
+ ktok_error(K, "Bad format in number");
+ return KINERT;
+ }
}
ks_tbclear(K);
if (has_exactp && !exactp) {
- krooted_tvs_push(K, n);
- n = kexact_to_inexact(K, n);
- krooted_tvs_pop(K);
+ krooted_tvs_push(K, n);
+ n = kexact_to_inexact(K, n);
+ krooted_tvs_pop(K);
}
return n;
}
@@ -612,23 +612,23 @@ TValue ktok_read_maybe_signed_numeric(klisp_State *K)
/* NOTE: can't be eof, it's either '+' or '-' */
char ch = (char) ktok_getc(K);
if (ktok_check_delimiter(K)) {
- ks_tbadd(K, ch);
- ks_tbadd(K, '\0');
- /* save the source info in the symbol */
- TValue si = ktok_get_source_info(K);
- krooted_tvs_push(K, si); /* will be popped by throw */
- TValue new_sym = ksymbol_new_bs(K, ks_tbget_buffer(K), 1, si);
- krooted_tvs_pop(K); /* already in symbol */
- krooted_tvs_push(K, new_sym);
- ks_tbclear(K); /* this shouldn't cause gc, but just in case */
- krooted_tvs_pop(K);
- return new_sym;
+ ks_tbadd(K, ch);
+ ks_tbadd(K, '\0');
+ /* save the source info in the symbol */
+ TValue si = ktok_get_source_info(K);
+ krooted_tvs_push(K, si); /* will be popped by throw */
+ TValue new_sym = ksymbol_new_bs(K, ks_tbget_buffer(K), 1, si);
+ krooted_tvs_pop(K); /* already in symbol */
+ krooted_tvs_push(K, new_sym);
+ ks_tbclear(K); /* this shouldn't cause gc, but just in case */
+ krooted_tvs_pop(K);
+ return new_sym;
} else {
- ks_tbadd(K, ch);
- int32_t buf_len = ktok_read_until_delimiter(K)+1;
- char *buf = ks_tbget_buffer(K);
- /* no exactness or radix prefix, default radix: 10 */
- return ktok_read_number(K, buf, buf_len, false, false, false, 10);
+ ks_tbadd(K, ch);
+ int32_t buf_len = ktok_read_until_delimiter(K)+1;
+ char *buf = ks_tbget_buffer(K);
+ /* no exactness or radix prefix, default radix: 10 */
+ return ktok_read_number(K, buf, buf_len, false, false, false, 10);
}
}
@@ -645,32 +645,32 @@ char ktok_read_hex_escape(klisp_State *K)
int c = 0;
bool at_least_onep = false;
for(ch = ktok_getc(K); ch != EOF && ch != ';';
- ch = ktok_getc(K)) {
- if (!ktok_is_digit(ch, 16)) {
- ktok_error_extra(K, "Invalid char found in hex escape",
- ch2tv(ch));
- return '\0'; /* avoid warning */
- }
- /*
- ** This will allow one space for '\0' and one extra
- ** char in case the value is too big, and so will
- ** naturally result in a value outside the unicode
- ** range without the need to record any extra
- ** characters other than the first 8 (without
- ** leading zeroes).
- */
- at_least_onep = true;
- if (c < sizeof(buf) - 1 && (c > 0 || ch != '0'))
- buf[c++] = ch;
+ ch = ktok_getc(K)) {
+ if (!ktok_is_digit(ch, 16)) {
+ ktok_error_extra(K, "Invalid char found in hex escape",
+ ch2tv(ch));
+ return '\0'; /* avoid warning */
+ }
+ /*
+ ** This will allow one space for '\0' and one extra
+ ** char in case the value is too big, and so will
+ ** naturally result in a value outside the unicode
+ ** range without the need to record any extra
+ ** characters other than the first 8 (without
+ ** leading zeroes).
+ */
+ at_least_onep = true;
+ if (c < sizeof(buf) - 1 && (c > 0 || ch != '0'))
+ buf[c++] = ch;
}
if (ch == EOF) {
- ktok_error(K, "EOF found while reading hex escape");
- return '\0'; /* avoid warning */
+ ktok_error(K, "EOF found while reading hex escape");
+ return '\0'; /* avoid warning */
} else if (!at_least_onep) {
- ktok_error(K, "Empty hex escape found");
- return '\0'; /* avoid warning */
+ ktok_error(K, "Empty hex escape found");
+ return '\0'; /* avoid warning */
} else if (c == 0) { /* this is the case of a NULL char */
- buf[c++] = '0';
+ buf[c++] = '0';
}
buf[c++] = '\0';
/* buf now contains the hex value of the char */
@@ -679,9 +679,9 @@ char ktok_read_hex_escape(klisp_State *K)
/* can't fail, all digits were checked already */
klisp_assert(res == true);
if (!ttisfixint(n) || ivalue(n) > 127) {
- krooted_tvs_push(K, n);
- ktok_error_extra(K, "hex escaped char out of ASCII range", n);
- return '\0'; /* avoid warning */
+ krooted_tvs_push(K, n);
+ ktok_error_extra(K, "hex escaped char out of ASCII range", n);
+ return '\0'; /* avoid warning */
}
/* all ok, we pass the char */
return (char) ivalue(n);
@@ -699,111 +699,111 @@ TValue ktok_read_string(klisp_State *K)
int i = 0;
while(!done) {
- int ch = ktok_getc(K);
+ int ch = ktok_getc(K);
just_read: /* this comes from escaped newline */
- if (ch == EOF) {
- ktok_error(K, "EOF found while reading a string");
- return KINERT; /* avoid warning */
- } else if (ch < 0 || ch > 127) {
- ktok_error(K, "Non ASCII char found while reading a string");
- return KINERT; /* avoid warning */
- }
-
-
- if (ch == '"') {
- ks_tbadd(K, '\0');
- done = true;
- } else if (ch == '\\') {
- ch = ktok_getc(K);
+ if (ch == EOF) {
+ ktok_error(K, "EOF found while reading a string");
+ return KINERT; /* avoid warning */
+ } else if (ch < 0 || ch > 127) {
+ ktok_error(K, "Non ASCII char found while reading a string");
+ return KINERT; /* avoid warning */
+ }
+
+
+ if (ch == '"') {
+ ks_tbadd(K, '\0');
+ done = true;
+ } else if (ch == '\\') {
+ ch = ktok_getc(K);
- if (ch == EOF) {
- ktok_error(K, "EOF found while reading a string");
- return KINERT; /* avoid warning */
- }
-
- switch(ch) {
- /* These two will self insert */
- case '"':
- case '\\':
- break;
- /* These are naming chars (like in c, mostly) */
- case '0':
- ch = '\0';
- break;
- case 'a':
- ch = '\a';
- break;
- case 'b':
- ch = '\b';
- break;
- case 't':
- ch = '\t';
- break;
- case 'n':
- ch = '\n';
- break;
- case 'r':
- ch = '\r';
- break;
- case 'v':
- ch = '\v';
- break;
- case 'f':
- ch = '\f';
- break;
- /*
- ** These signal an escaped newline (not included in string)
- */
- case ' ':
- case '\t':
- /* eat up all intraline spacing */
- while((ch = ktok_getc(K)) != EOF &&
- (ch == ' ' || ch == '\t'))
- ;
- if (ch == EOF) {
- ktok_error(K, "EOF found while reading a string");
- return KINERT; /* avoid warning */
- } else if (ch != '\n' && ch != '\r') {
- ktok_error(K, "Invalid char found after \\ while "
- "reading a string");
- return KINERT; /* avoid warning */
- }
- /* fall through */
- case '\n':
- case '\r':
- /* use the r6rs definition for line end */
- if (ch == 'r') {
- ch = ktok_peekc(K);
- if (ch != EOF && ch == '\n')
- ktok_getc(K);
- }
- /* eat up all intraline spacing */
- while((ch = ktok_getc(K)) != EOF &&
- (ch == ' ' || ch == '\t'))
- ;
- /* this will check for EOF and continue reading the
- string at the top of the loop */
- goto just_read;
- /* This is an hex escaped char */
- case 'x':
- ch = ktok_read_hex_escape(K);
- break;
- default:
- ktok_error_extra(K, "Invalid char after '\\' "
- "while reading a string", ch2tv(ch));
- return KINERT; /* avoid warning */
- }
- ks_tbadd(K, ch);
- ++i;
- } else {
- ks_tbadd(K, ch);
- ++i;
- }
+ if (ch == EOF) {
+ ktok_error(K, "EOF found while reading a string");
+ return KINERT; /* avoid warning */
+ }
+
+ switch(ch) {
+ /* These two will self insert */
+ case '"':
+ case '\\':
+ break;
+ /* These are naming chars (like in c, mostly) */
+ case '0':
+ ch = '\0';
+ break;
+ case 'a':
+ ch = '\a';
+ break;
+ case 'b':
+ ch = '\b';
+ break;
+ case 't':
+ ch = '\t';
+ break;
+ case 'n':
+ ch = '\n';
+ break;
+ case 'r':
+ ch = '\r';
+ break;
+ case 'v':
+ ch = '\v';
+ break;
+ case 'f':
+ ch = '\f';
+ break;
+ /*
+ ** These signal an escaped newline (not included in string)
+ */
+ case ' ':
+ case '\t':
+ /* eat up all intraline spacing */
+ while((ch = ktok_getc(K)) != EOF &&
+ (ch == ' ' || ch == '\t'))
+ ;
+ if (ch == EOF) {
+ ktok_error(K, "EOF found while reading a string");
+ return KINERT; /* avoid warning */
+ } else if (ch != '\n' && ch != '\r') {
+ ktok_error(K, "Invalid char found after \\ while "
+ "reading a string");
+ return KINERT; /* avoid warning */
+ }
+ /* fall through */
+ case '\n':
+ case '\r':
+ /* use the r6rs definition for line end */
+ if (ch == 'r') {
+ ch = ktok_peekc(K);
+ if (ch != EOF && ch == '\n')
+ ktok_getc(K);
+ }
+ /* eat up all intraline spacing */
+ while((ch = ktok_getc(K)) != EOF &&
+ (ch == ' ' || ch == '\t'))
+ ;
+ /* this will check for EOF and continue reading the
+ string at the top of the loop */
+ goto just_read;
+ /* This is an hex escaped char */
+ case 'x':
+ ch = ktok_read_hex_escape(K);
+ break;
+ default:
+ ktok_error_extra(K, "Invalid char after '\\' "
+ "while reading a string", ch2tv(ch));
+ return KINERT; /* avoid warning */
+ }
+ ks_tbadd(K, ch);
+ ++i;
+ } else {
+ ks_tbadd(K, ch);
+ ++i;
+ }
}
/* TEMP: for now strings "read" are mutable but strings "loaded" are
not */
TValue new_str = kstring_new_bs_g(K, K->read_mconsp,
- ks_tbget_buffer(K), i);
+ ks_tbget_buffer(K), i);
krooted_tvs_push(K, new_str);
ks_tbclear(K); /* shouldn't cause gc, but still */
krooted_tvs_pop(K);
@@ -820,31 +820,31 @@ struct kspecial_token {
const char *ext_rep; /* downcase external representation */
TValue obj;
} kspecial_tokens[] = { { "#t", KTRUE_ },
- { "#f", KFALSE_ },
- { "#ignore", KIGNORE_ },
- { "#inert", KINERT_ },
- { "#e+infinity", KEPINF_ },
- { "#e-infinity", KEMINF_ },
- { "#i+infinity", KIPINF_ },
- { "#i-infinity", KIMINF_ },
- { "#real", KRWNPV_ },
- { "#undefined", KUNDEF_ },
- /*
- ** Character names
- ** (r7rs + vtab from r6rs)
- */
- { "#\\null", KNULL_ },
- { "#\\alarm", KALARM_ },
- { "#\\backspace", KBACKSPACE_ },
- { "#\\tab", KTAB_ },
- { "#\\newline", KNEWLINE_ }, /* kernel */
- { "#\\return", KRETURN_ },
- { "#\\escape", KESCAPE_ },
- { "#\\space", KSPACE_ }, /* kernel */
- { "#\\delete", KDELETE_ },
- { "#\\vtab", KVTAB_ }, /* r6rs, only */
- { "#\\formfeed", KFORMFEED_ } /* r6rs in strings */
- };
+ { "#f", KFALSE_ },
+ { "#ignore", KIGNORE_ },
+ { "#inert", KINERT_ },
+ { "#e+infinity", KEPINF_ },
+ { "#e-infinity", KEMINF_ },
+ { "#i+infinity", KIPINF_ },
+ { "#i-infinity", KIMINF_ },
+ { "#real", KRWNPV_ },
+ { "#undefined", KUNDEF_ },
+ /*
+ ** Character names
+ ** (r7rs + vtab from r6rs)
+ */
+ { "#\\null", KNULL_ },
+ { "#\\alarm", KALARM_ },
+ { "#\\backspace", KBACKSPACE_ },
+ { "#\\tab", KTAB_ },
+ { "#\\newline", KNEWLINE_ }, /* kernel */
+ { "#\\return", KRETURN_ },
+ { "#\\escape", KESCAPE_ },
+ { "#\\space", KSPACE_ }, /* kernel */
+ { "#\\delete", KDELETE_ },
+ { "#\\vtab", KVTAB_ }, /* r6rs, only */
+ { "#\\formfeed", KFORMFEED_ } /* r6rs in strings */
+};
#define MAX_EXT_REP_SIZE 64 /* all special tokens have less than 64 chars */
@@ -856,19 +856,19 @@ TValue ktok_read_special(klisp_State *K)
char *buf = ks_tbget_buffer(K);
if (buf_len < 2) {
- /* we need at least one char in addition to the '#' */
- ktok_error(K, "# constant is too short");
- /* avoid warning */
- return KINERT;
+ /* we need at least one char in addition to the '#' */
+ ktok_error(K, "# constant is too short");
+ /* avoid warning */
+ return KINERT;
}
/* first check that is not an output only representation,
they begin with '#[' and end with ']', but we know
that buf[0] == '#' */
if (buf_len > 2 && buf[1] == '[' && buf[buf_len-1] == ']') {
- ktok_error(K, "output only representation found");
- /* avoid warning */
- return KINERT;
+ ktok_error(K, "output only representation found");
+ /* avoid warning */
+ return KINERT;
}
/* Then check for simple chars, this is the only thing
@@ -878,96 +878,96 @@ TValue ktok_read_special(klisp_State *K)
/* char constant, needs at least 3 chars unless it's a delimiter
* char! */
if (buf_len == 2 && buf[1] == '\\') {
- /* was a delimiter char... read it */
- int ch_i = ktok_getc(K);
- if (ch_i == EOF) {
- ktok_error(K, "EOF found while reading character name");
- return KINERT; /* avoid warning */
- }
- ks_tbclear(K);
- return ch2tv((char)ch_i);
+ /* was a delimiter char... read it */
+ int ch_i = ktok_getc(K);
+ if (ch_i == EOF) {
+ ktok_error(K, "EOF found while reading character name");
+ return KINERT; /* avoid warning */
+ }
+ ks_tbclear(K);
+ return ch2tv((char)ch_i);
} else if (buf[1] == '\\') {
- /*
- ** RATIONALE: in the scheme spec (R5RS) it says that only alphabetic
- ** char constants need a delimiter to disambiguate the cases with
- ** character names. It would be more consistent if all characters
- ** needed a delimiter (and is probably implied by the yet incomplete
- ** Kernel report (R-1RK))
- ** For now we follow the scheme report
- */
- char ch = buf[2]; /* we know buf_len > 2 */
-
- if (ch < 0 || ch > 127) {
- ktok_error(K, "Non ASCII char found as character constant");
- /* avoid warning */
- return KINERT;
- }
-
- if (!ktok_is_alphabetic(ch) || buf_len == 3) { /* simple char */
- ks_tbclear(K);
- return ch2tv(ch);
- }
-
- /* char names are a subcase of special tokens so this case
- will be handled later */
- /* fall through */
+ /*
+ ** RATIONALE: in the scheme spec (R5RS) it says that only alphabetic
+ ** char constants need a delimiter to disambiguate the cases with
+ ** character names. It would be more consistent if all characters
+ ** needed a delimiter (and is probably implied by the yet incomplete
+ ** Kernel report (R-1RK))
+ ** For now we follow the scheme report
+ */
+ char ch = buf[2]; /* we know buf_len > 2 */
+
+ if (ch < 0 || ch > 127) {
+ ktok_error(K, "Non ASCII char found as character constant");
+ /* avoid warning */
+ return KINERT;
+ }
+
+ if (!ktok_is_alphabetic(ch) || buf_len == 3) { /* simple char */
+ ks_tbclear(K);
+ return ch2tv(ch);
+ }
+
+ /* char names are a subcase of special tokens so this case
+ will be handled later */
+ /* fall through */
}
/* first save the third char, in case it's an hex escaped char
(that should be a lowercase x) */
char saved_third = buf[2]; /* there's at least 2 chars, so in the worst
- case buf[2] is just '\0' */
+ case buf[2] is just '\0' */
/* now, we ignore case in all remaining comparisons */
size_t i = 0;
for(char *str2 = buf; i < buf_len; ++str2, ++i)
- *str2 = tolower(*str2);
+ *str2 = tolower(*str2);
/* REFACTOR: move this to a new function */
/* then check the known constants (including named characters) */
size_t stok_size = sizeof(kspecial_tokens) /
- sizeof(struct kspecial_token);
+ sizeof(struct kspecial_token);
for (i = 0; i < stok_size; i++) {
- struct kspecial_token token = kspecial_tokens[i];
- /* NOTE: must check type because buf may contain embedded '\0's */
- if (buf_len == strlen(token.ext_rep) &&
- strcmp(token.ext_rep, buf) == 0) {
- ks_tbclear(K);
- return token.obj;
- }
+ struct kspecial_token token = kspecial_tokens[i];
+ /* NOTE: must check type because buf may contain embedded '\0's */
+ if (buf_len == strlen(token.ext_rep) &&
+ strcmp(token.ext_rep, buf) == 0) {
+ ks_tbclear(K);
+ return token.obj;
+ }
}
/* It wasn't a special token or named char, but it can still be a srfi-38
token or a character escape */
if (buf[1] == '\\') { /* this is to have a meaningful error msg */
- if (saved_third != 'x') { /* case is significant here, so
- we use the saved char */
- ktok_error(K, "Unrecognized character name");
- return KINERT;
- }
- /* We already checked that length != 3 (x is alphabetic),
- so there's at least on more char */
- TValue n;
- char *end;
-
- /* test for - and + explicitly, becayse kinteger read would parse them
- without complaining (it will also parse spaces, but we read until
- delimiter so... */
- if (buf[3] == '-' || buf[3] == '+' ||
- !kinteger_read(K, buf+3, 16, &n, &end) ||
- end - buf != buf_len) {
- ktok_error(K, "Bad char in hex escaped character constant");
- return KINERT;
- } else if (!ttisfixint(n) || ivalue(n) > 127) {
- ktok_error(K, "Non ASCII char found in hex escaped character constant");
- /* avoid warning */
- return KINERT;
- } else {
- /* all ok, we just clean up and return the char */
- ks_tbclear(K);
- return ch2tv(ivalue(n));
- }
+ if (saved_third != 'x') { /* case is significant here, so
+ we use the saved char */
+ ktok_error(K, "Unrecognized character name");
+ return KINERT;
+ }
+ /* We already checked that length != 3 (x is alphabetic),
+ so there's at least on more char */
+ TValue n;
+ char *end;
+
+ /* test for - and + explicitly, becayse kinteger read would parse them
+ without complaining (it will also parse spaces, but we read until
+ delimiter so... */
+ if (buf[3] == '-' || buf[3] == '+' ||
+ !kinteger_read(K, buf+3, 16, &n, &end) ||
+ end - buf != buf_len) {
+ ktok_error(K, "Bad char in hex escaped character constant");
+ return KINERT;
+ } else if (!ttisfixint(n) || ivalue(n) > 127) {
+ ktok_error(K, "Non ASCII char found in hex escaped character constant");
+ /* avoid warning */
+ return KINERT;
+ } else {
+ /* all ok, we just clean up and return the char */
+ ks_tbclear(K);
+ return ch2tv(ivalue(n));
+ }
}
/* REFACTOR: move this to a new function */
@@ -975,34 +975,34 @@ TValue ktok_read_special(klisp_State *K)
token, or a number. srfi-38 tokens are a '#' a
decimal number and end with a '=' or a '#' */
if (buf_len > 2 && ktok_is_numeric(buf[1])) {
- /* NOTE: it's important to check is_numeric to avoid problems with
- sign in kinteger_read */
- /* srfi-38 type token (can be either a def or ref) */
- /* TODO: lift this implementation restriction */
- /* IMPLEMENTATION RESTRICTION: only allow fixints in shared tokens */
- char ch = buf[buf_len-1]; /* remember last char */
- buf[buf_len-1] = '\0'; /* replace last char with 0 to read number */
-
- if (ch != '#' && ch != '=') {
- ktok_error(K, "Missing last char in srfi-38 token");
- return KINERT;
- } /* else buf[i] == '#' or '=' */
- TValue n;
- char *end;
- /* 10 is the radix for srfi-38 tokens, buf+1 to jump over the '#',
- end+1 to count the last char */
- /* N.B. buf+1 can't be + or -, we already tested numeric before */
- if (!kinteger_read(K, buf+1, 10, &n, &end) || end+1 - buf != buf_len) {
- ktok_error(K, "Bad char in srfi-38 token");
- return KINERT;
- } else if (!ttisfixint(n)) {
- ktok_error(K, "IMP. RESTRICTION: shared token too big");
- /* avoid warning */
- return KINERT;
- }
- ks_tbclear(K);
- /* GC: no need to root n, for now it's a fixint */
- return kcons(K, ch2tv(ch), n);
+ /* NOTE: it's important to check is_numeric to avoid problems with
+ sign in kinteger_read */
+ /* srfi-38 type token (can be either a def or ref) */
+ /* TODO: lift this implementation restriction */
+ /* IMPLEMENTATION RESTRICTION: only allow fixints in shared tokens */
+ char ch = buf[buf_len-1]; /* remember last char */
+ buf[buf_len-1] = '\0'; /* replace last char with 0 to read number */
+
+ if (ch != '#' && ch != '=') {
+ ktok_error(K, "Missing last char in srfi-38 token");
+ return KINERT;
+ } /* else buf[i] == '#' or '=' */
+ TValue n;
+ char *end;
+ /* 10 is the radix for srfi-38 tokens, buf+1 to jump over the '#',
+ end+1 to count the last char */
+ /* N.B. buf+1 can't be + or -, we already tested numeric before */
+ if (!kinteger_read(K, buf+1, 10, &n, &end) || end+1 - buf != buf_len) {
+ ktok_error(K, "Bad char in srfi-38 token");
+ return KINERT;
+ } else if (!ttisfixint(n)) {
+ ktok_error(K, "IMP. RESTRICTION: shared token too big");
+ /* avoid warning */
+ return KINERT;
+ }
+ ks_tbclear(K);
+ /* GC: no need to root n, for now it's a fixint */
+ return kcons(K, ch2tv(ch), n);
}
/* REFACTOR: move to new function */
@@ -1016,61 +1016,61 @@ TValue ktok_read_special(klisp_State *K)
int32_t idx = 1;
while (idx < buf_len) {
- char ch = buf[idx];
- switch(ch) {
- case 'i':
- case 'e':
- if (has_exactp) {
- ktok_error(K, "two exactness prefixes in number");
- return KINERT;
- }
- has_exactp = true;
- exactp = (ch == 'e');
- break;
- case 'b': radix = 2; goto RADIX;
- case 'o': radix = 8; goto RADIX;
- case 'd': radix = 10; goto RADIX;
- case 'x': radix = 16; goto RADIX;
- RADIX:
- if (has_radixp) {
- ktok_error(K, "two radix prefixes in number");
- return KINERT;
- }
- has_radixp = true;
- break;
- default:
- ktok_error(K, "unknown # constant or "
- "unexpected char in number after #");
- /* avoid warning */
- return KINERT;
- }
- ++idx;
- if (idx == buf_len)
- break;
- ch = buf[idx];
-
- switch(ch) {
- case '#': {
- ++idx; /* get next exacness or radix prefix */
- break;
- }
- case '0': case '1': case '2': case '3': case '4':
- case '5': case '6': case '7': case '8': case '9':
- case 'a': case 'b': case 'c': case 'd': case 'e':
- case 'f': case '+': case '-': { /* read the number */
- if (idx == buf_len) {
- ktok_error(K, "no digits found in number");
- } else {
- return ktok_read_number(K, buf+idx, buf_len - idx,
- has_exactp, exactp,
- has_radixp, radix);
- }
- }
- default:
- ktok_error(K, "unexpected char in number");
- /* avoid warning */
- return KINERT;
- }
+ char ch = buf[idx];
+ switch(ch) {
+ case 'i':
+ case 'e':
+ if (has_exactp) {
+ ktok_error(K, "two exactness prefixes in number");
+ return KINERT;
+ }
+ has_exactp = true;
+ exactp = (ch == 'e');
+ break;
+ case 'b': radix = 2; goto RADIX;
+ case 'o': radix = 8; goto RADIX;
+ case 'd': radix = 10; goto RADIX;
+ case 'x': radix = 16; goto RADIX;
+ RADIX:
+ if (has_radixp) {
+ ktok_error(K, "two radix prefixes in number");
+ return KINERT;
+ }
+ has_radixp = true;
+ break;
+ default:
+ ktok_error(K, "unknown # constant or "
+ "unexpected char in number after #");
+ /* avoid warning */
+ return KINERT;
+ }
+ ++idx;
+ if (idx == buf_len)
+ break;
+ ch = buf[idx];
+
+ switch(ch) {
+ case '#': {
+ ++idx; /* get next exacness or radix prefix */
+ break;
+ }
+ case '0': case '1': case '2': case '3': case '4':
+ case '5': case '6': case '7': case '8': case '9':
+ case 'a': case 'b': case 'c': case 'd': case 'e':
+ case 'f': case '+': case '-': { /* read the number */
+ if (idx == buf_len) {
+ ktok_error(K, "no digits found in number");
+ } else {
+ return ktok_read_number(K, buf+idx, buf_len - idx,
+ has_exactp, exactp,
+ has_radixp, radix);
+ }
+ }
+ default:
+ ktok_error(K, "unexpected char in number");
+ /* avoid warning */
+ return KINERT;
+ }
}
/* this means that the number wasn't found after the prefixes */
ktok_error(K, "no digits found in number");
@@ -1086,55 +1086,55 @@ TValue ktok_read_identifier_or_dot(klisp_State *K, bool keywordp)
bool seen_dot = false;
int32_t i = 0;
while (!ktok_check_delimiter(K)) {
- /* NOTE: can't be eof, because eof is a delimiter */
- char ch = (char) ktok_getc(K);
- /* this is needed to differentiate a dot from an equivalent escape */
- seen_dot |= ch == '.';
- /* NOTE: is_subsequent of '\0' is false, so no embedded '\0' */
- if (ktok_is_subsequent(ch)) {
- /* downcase all non-escaped chars */
- ks_tbadd(K, tolower(ch));
- ++i;
- } else if (ch == '\\') {
- /* should be inline hex escape */
- ch = ktok_getc(K);
- if (ch == EOF) {
- ktok_error(K, "EOF found while reading character escape");
- } else if (ch != 'x') {
- ktok_error_extra(K, keywordp?
- "Invalid char after \\ in keyword" :
- "Invalid char after \\ in identifier",
- ch2tv((char)ch));
- }
- ch = ktok_read_hex_escape(K);
- /* don't downcase escaped chars */
- ks_tbadd(K, ch);
- ++i;
- } else {
- ktok_error_extra(K, keywordp? "Invalid char in keyword" :
- "Invalid char in identifier", ch2tv((char)ch));
- }
+ /* NOTE: can't be eof, because eof is a delimiter */
+ char ch = (char) ktok_getc(K);
+ /* this is needed to differentiate a dot from an equivalent escape */
+ seen_dot |= ch == '.';
+ /* NOTE: is_subsequent of '\0' is false, so no embedded '\0' */
+ if (ktok_is_subsequent(ch)) {
+ /* downcase all non-escaped chars */
+ ks_tbadd(K, tolower(ch));
+ ++i;
+ } else if (ch == '\\') {
+ /* should be inline hex escape */
+ ch = ktok_getc(K);
+ if (ch == EOF) {
+ ktok_error(K, "EOF found while reading character escape");
+ } else if (ch != 'x') {
+ ktok_error_extra(K, keywordp?
+ "Invalid char after \\ in keyword" :
+ "Invalid char after \\ in identifier",
+ ch2tv((char)ch));
+ }
+ ch = ktok_read_hex_escape(K);
+ /* don't downcase escaped chars */
+ ks_tbadd(K, ch);
+ ++i;
+ } else {
+ ktok_error_extra(K, keywordp? "Invalid char in keyword" :
+ "Invalid char in identifier", ch2tv((char)ch));
+ }
}
if (i == 1 && seen_dot) {
- if (keywordp) {
- ktok_error(K, "Invalid syntax in keyword");
- return KINERT; /* avoid warning */
- } else {
- ks_tbclear(K);
- return K->ktok_dot;
- }
+ if (keywordp) {
+ ktok_error(K, "Invalid syntax in keyword");
+ return KINERT; /* avoid warning */
+ } else {
+ ks_tbclear(K);
+ return K->ktok_dot;
+ }
}
ks_tbadd(K, '\0');
TValue new_obj;
if (keywordp) {
- new_obj = kkeyword_new_bs(K, ks_tbget_buffer(K), i);
+ new_obj = kkeyword_new_bs(K, ks_tbget_buffer(K), i);
} else {
- TValue si = ktok_get_source_info(K);
- krooted_tvs_push(K, si); /* will be popped by throw */
- new_obj = ksymbol_new_bs(K, ks_tbget_buffer(K), i, si);
- krooted_tvs_pop(K); /* already in symbol */
+ TValue si = ktok_get_source_info(K);
+ krooted_tvs_push(K, si); /* will be popped by throw */
+ new_obj = ksymbol_new_bs(K, ks_tbget_buffer(K), i, si);
+ krooted_tvs_pop(K); /* already in symbol */
}
krooted_tvs_push(K, new_obj);
ks_tbclear(K); /* this shouldn't cause gc, but just in case */
@@ -1152,63 +1152,63 @@ TValue ktok_read_bar_identifier(klisp_State *K, bool keywordp)
/* Never downcase chars in |...| escaped symbols */
while(!done) {
- int ch = ktok_getc(K);
- if (ch == EOF) {
- ktok_error(K, keywordp?
- "EOF found while reading a #:|keyword|" :
- "EOF found while reading an |identifier|");
- return KINERT; /* avoid warning */
- } else if (ch < 0 || ch > 127) {
- ktok_error(K, keywordp?
- "Non ASCII char found while reading a #:|keyword|" :
- "Non ASCII char found while reading an |identifier|");
- return KINERT; /* avoid warning */
- }
-
- if (ch == '|') {
- ks_tbadd(K, '\0');
- done = true;
- } else if (ch == '\\') {
- ch = ktok_getc(K);
+ int ch = ktok_getc(K);
+ if (ch == EOF) {
+ ktok_error(K, keywordp?
+ "EOF found while reading a #:|keyword|" :
+ "EOF found while reading an |identifier|");
+ return KINERT; /* avoid warning */
+ } else if (ch < 0 || ch > 127) {
+ ktok_error(K, keywordp?
+ "Non ASCII char found while reading a #:|keyword|" :
+ "Non ASCII char found while reading an |identifier|");
+ return KINERT; /* avoid warning */
+ }
+
+ if (ch == '|') {
+ ks_tbadd(K, '\0');
+ done = true;
+ } else if (ch == '\\') {
+ ch = ktok_getc(K);
- if (ch == EOF) {
- ktok_error(K, keywordp?
- "EOF found while reading a #:|keyword|" :
- "EOF found while reading an |identifier|");
- return KINERT; /* avoid warning */
- }
-
- switch(ch) {
- /* These two will self insert */
- case '|':
- case '\\':
- break;
- case 'x':
- ch = ktok_read_hex_escape(K);
- break;
- default:
- ktok_error_extra(K, keywordp?
- "Invalid char after '\\' while reading a "
- "#:|keyword|" :
- "Invalid char after '\\' while reading an "
- "|identifier|", ch2tv(ch));
- return KINERT; /* avoid warning */
- }
- ks_tbadd(K, ch);
- ++i;
- } else {
- ks_tbadd(K, ch);
- ++i;
- }
+ if (ch == EOF) {
+ ktok_error(K, keywordp?
+ "EOF found while reading a #:|keyword|" :
+ "EOF found while reading an |identifier|");
+ return KINERT; /* avoid warning */
+ }
+
+ switch(ch) {
+ /* These two will self insert */
+ case '|':
+ case '\\':
+ break;
+ case 'x':
+ ch = ktok_read_hex_escape(K);
+ break;
+ default:
+ ktok_error_extra(K, keywordp?
+ "Invalid char after '\\' while reading a "
+ "#:|keyword|" :
+ "Invalid char after '\\' while reading an "
+ "|identifier|", ch2tv(ch));
+ return KINERT; /* avoid warning */
+ }
+ ks_tbadd(K, ch);
+ ++i;
+ } else {
+ ks_tbadd(K, ch);
+ ++i;
+ }
}
TValue new_obj;
if (keywordp) {
- new_obj = kkeyword_new_bs(K, ks_tbget_buffer(K), i);
+ new_obj = kkeyword_new_bs(K, ks_tbget_buffer(K), i);
} else {
- TValue si = ktok_get_source_info(K);
- krooted_tvs_push(K, si); /* will be popped by throw */
- new_obj = ksymbol_new_bs(K, ks_tbget_buffer(K), i, si);
- krooted_tvs_pop(K); /* already in symbol */
+ TValue si = ktok_get_source_info(K);
+ krooted_tvs_push(K, si); /* will be popped by throw */
+ new_obj = ksymbol_new_bs(K, ks_tbget_buffer(K), i, si);
+ krooted_tvs_pop(K); /* already in symbol */
}
krooted_tvs_push(K, new_obj);
ks_tbclear(K); /* this shouldn't cause gc, but just in case */
diff --git a/src/ktoken.h b/src/ktoken.h
@@ -22,7 +22,7 @@ TValue ktok_read_token(klisp_State *K);
/* return a fresh ilist of the form (filename line . col) */
TValue ktok_get_source_info(klisp_State *K);
void ktok_set_source_info(klisp_State *K, TValue filename, int32_t line,
- int32_t col);
+ int32_t col);
/* This is needed here to allow cleanup of shared dict from tokenizer */
void clear_shared_dict(klisp_State *K);
@@ -55,21 +55,21 @@ extern kcharset ktok_subsequent, ktok_initial;
#define ktok_is_numeric(chi_) kcharset_contains(ktok_numeric, chi_)
#define ktok_is_whitespace(chi_) kcharset_contains(ktok_whitespace, chi_)
-#define ktok_is_delimiter(chi_) ((chi_) == EOF || \
- kcharset_contains(ktok_delimiter, chi_))
+#define ktok_is_delimiter(chi_) ((chi_) == EOF || \
+ kcharset_contains(ktok_delimiter, chi_))
#define ktok_is_initial(chi_) kcharset_contains(ktok_initial, chi_)
#define ktok_is_subsequent(chi_) kcharset_contains(ktok_subsequent, chi_)
-#define kcharset_contains(kch_, ch_) \
- ({ unsigned char ch__ = (unsigned char) (ch_); \
- kch_[KCHS_OCTANT(ch__)] & KCHS_BIT(ch__); })
+#define kcharset_contains(kch_, ch_) \
+ ({ unsigned char ch__ = (unsigned char) (ch_); \
+ kch_[KCHS_OCTANT(ch__)] & KCHS_BIT(ch__); })
inline bool ktok_is_digit(char ch, int32_t radix)
{
ch = tolower(ch);
return (ktok_is_numeric(ch) && (ch - '0') < radix) ||
- (ktok_is_alphabetic(ch) && (10 + (ch - 'a')) < radix);
+ (ktok_is_alphabetic(ch) && (10 + (ch - 'a')) < radix);
}
inline int32_t ktok_digit_value(char ch)
diff --git a/src/kwrite.c b/src/kwrite.c
@@ -52,51 +52,51 @@ void kw_printf(klisp_State *K, const char *format, ...)
TValue port = K->curr_port;
if (ttisfport(port)) {
- FILE *file = kfport_file(port);
- va_start(argp, format);
- int ret = vfprintf(file, format, argp);
- va_end(argp);
-
- if (ret < 0) {
- clearerr(file); /* clear error for next time */
- kwrite_error(K, "error writing");
- return;
- }
+ FILE *file = kfport_file(port);
+ va_start(argp, format);
+ int ret = vfprintf(file, format, argp);
+ va_end(argp);
+
+ if (ret < 0) {
+ clearerr(file); /* clear error for next time */
+ kwrite_error(K, "error writing");
+ return;
+ }
} else if (ttismport(port)) {
- /* bytevector ports shouldn't write chars */
- klisp_assert(kport_is_textual(port));
- /* string port */
- uint32_t size;
- int written;
- uint32_t off = kmport_off(port);
-
- size = kstring_size(kmport_buf(port)) -
- kmport_off(port) + 1;
-
- /* size is always at least 1 (for the '\0') */
- va_start(argp, format);
- written = vsnprintf(kstring_buf(kmport_buf(port)) + off,
- size, format, argp);
- va_end(argp);
-
- if (written >= size) { /* space wasn't enough */
- kmport_resize_buffer(K, port, off + written);
- /* size may be greater than off + written, so get again */
- size = kstring_size(kmport_buf(port)) - off + 1;
- va_start(argp, format);
- written = vsnprintf(kstring_buf(kmport_buf(port)) + off,
- size, format, argp);
- va_end(argp);
- if (written < 0 || written >= size) {
- /* shouldn't happen */
- kwrite_error(K, "error writing");
- return;
- }
- }
- kmport_off(port) = off + written;
+ /* bytevector ports shouldn't write chars */
+ klisp_assert(kport_is_textual(port));
+ /* string port */
+ uint32_t size;
+ int written;
+ uint32_t off = kmport_off(port);
+
+ size = kstring_size(kmport_buf(port)) -
+ kmport_off(port) + 1;
+
+ /* size is always at least 1 (for the '\0') */
+ va_start(argp, format);
+ written = vsnprintf(kstring_buf(kmport_buf(port)) + off,
+ size, format, argp);
+ va_end(argp);
+
+ if (written >= size) { /* space wasn't enough */
+ kmport_resize_buffer(K, port, off + written);
+ /* size may be greater than off + written, so get again */
+ size = kstring_size(kmport_buf(port)) - off + 1;
+ va_start(argp, format);
+ written = vsnprintf(kstring_buf(kmport_buf(port)) + off,
+ size, format, argp);
+ va_end(argp);
+ if (written < 0 || written >= size) {
+ /* shouldn't happen */
+ kwrite_error(K, "error writing");
+ return;
+ }
+ }
+ kmport_off(port) = off + written;
} else {
- kwrite_error(K, "unknown port type");
- return;
+ kwrite_error(K, "unknown port type");
+ return;
}
}
@@ -174,67 +174,67 @@ void kw_print_string(klisp_State *K, TValue str)
int i = 0;
if (!K->write_displayp)
- kw_printf(K, "\"");
+ kw_printf(K, "\"");
while (i < size) {
- /* find the longest printf-able substring to avoid calling printf
- for every char */
- for (ptr = buf;
- i < size && *ptr != '\0' &&
- (*ptr >= 32 && *ptr < 127) &&
- (K->write_displayp || (*ptr != '\\' && *ptr != '"'));
- i++, ptr++)
- ;
-
- /* NOTE: this work even if ptr == buf (which can only happen the
- first or last time) */
- char ch = *ptr;
- *ptr = '\0';
- kw_printf(K, "%s", buf);
- *ptr = ch;
-
- for(; i < size && (*ptr == '\0' || (*ptr < 32 || *ptr >= 127) ||
- (!K->write_displayp &&
- (*ptr == '\\' || *ptr == '"')));
- ++i, ptr++) {
- /* This are all ASCII printable characters (including space,
- and exceptuating '\' and '"' if !displayp) */
- char *fmt;
- /* must be uint32_t to support all unicode chars
- in the future */
- uint32_t arg;
- ch = *ptr;
- if (K->write_displayp) {
- fmt = "%c";
- /* in display only show tabs and newlines,
- all other non printables are shown as spaces */
- arg = (uint32_t) ((ch == '\r' || ch == '\n' || ch == '\t')?
- ch : ' ');
- } else {
- switch(*ptr) {
- /* regular \ escapes */
- case '\"': fmt = "\\%c"; arg = (uint32_t) '"'; break;
- case '\\': fmt = "\\%c"; arg = (uint32_t) '\\'; break;
- case '\0': fmt = "\\%c"; arg = (uint32_t) '0'; break;
- case '\a': fmt = "\\%c"; arg = (uint32_t) 'a'; break;
- case '\b': fmt = "\\%c"; arg = (uint32_t) 'b'; break;
- case '\t': fmt = "\\%c"; arg = (uint32_t) 't'; break;
- case '\n': fmt = "\\%c"; arg = (uint32_t) 'n'; break;
- case '\r': fmt = "\\%c"; arg = (uint32_t) 'r'; break;
- case '\v': fmt = "\\%c"; arg = (uint32_t) 'v'; break;
- case '\f': fmt = "\\%c"; arg = (uint32_t) 'f'; break;
- /* for the rest of the non printable chars,
- use hex escape */
- default: fmt = "\\x%x;"; arg = (uint32_t) ch; break;
- }
- }
- kw_printf(K, fmt, arg);
- }
- buf = ptr;
+ /* find the longest printf-able substring to avoid calling printf
+ for every char */
+ for (ptr = buf;
+ i < size && *ptr != '\0' &&
+ (*ptr >= 32 && *ptr < 127) &&
+ (K->write_displayp || (*ptr != '\\' && *ptr != '"'));
+ i++, ptr++)
+ ;
+
+ /* NOTE: this work even if ptr == buf (which can only happen the
+ first or last time) */
+ char ch = *ptr;
+ *ptr = '\0';
+ kw_printf(K, "%s", buf);
+ *ptr = ch;
+
+ for(; i < size && (*ptr == '\0' || (*ptr < 32 || *ptr >= 127) ||
+ (!K->write_displayp &&
+ (*ptr == '\\' || *ptr == '"')));
+ ++i, ptr++) {
+ /* This are all ASCII printable characters (including space,
+ and exceptuating '\' and '"' if !displayp) */
+ char *fmt;
+ /* must be uint32_t to support all unicode chars
+ in the future */
+ uint32_t arg;
+ ch = *ptr;
+ if (K->write_displayp) {
+ fmt = "%c";
+ /* in display only show tabs and newlines,
+ all other non printables are shown as spaces */
+ arg = (uint32_t) ((ch == '\r' || ch == '\n' || ch == '\t')?
+ ch : ' ');
+ } else {
+ switch(*ptr) {
+ /* regular \ escapes */
+ case '\"': fmt = "\\%c"; arg = (uint32_t) '"'; break;
+ case '\\': fmt = "\\%c"; arg = (uint32_t) '\\'; break;
+ case '\0': fmt = "\\%c"; arg = (uint32_t) '0'; break;
+ case '\a': fmt = "\\%c"; arg = (uint32_t) 'a'; break;
+ case '\b': fmt = "\\%c"; arg = (uint32_t) 'b'; break;
+ case '\t': fmt = "\\%c"; arg = (uint32_t) 't'; break;
+ case '\n': fmt = "\\%c"; arg = (uint32_t) 'n'; break;
+ case '\r': fmt = "\\%c"; arg = (uint32_t) 'r'; break;
+ case '\v': fmt = "\\%c"; arg = (uint32_t) 'v'; break;
+ case '\f': fmt = "\\%c"; arg = (uint32_t) 'f'; break;
+ /* for the rest of the non printable chars,
+ use hex escape */
+ default: fmt = "\\x%x;"; arg = (uint32_t) ch; break;
+ }
+ }
+ kw_printf(K, fmt, arg);
+ }
+ buf = ptr;
}
if (!K->write_displayp)
- kw_printf(K, "\"");
+ kw_printf(K, "\"");
}
/*
@@ -248,28 +248,28 @@ void kw_print_symbol_buf(klisp_State *K, char *buf, uint32_t size)
/* first determine if it's a simple identifier */
bool identifierp;
if (size == 0)
- identifierp = false;
+ identifierp = false;
else if (size == 1 && *buf == '.')
- identifierp = false;
+ identifierp = false;
else if (size == 1 && (*buf == '+' || *buf == '-'))
- identifierp = true;
+ identifierp = true;
else if (*buf == tolower(*buf) && ktok_is_initial(*buf)) {
- char *ptr = buf;
- uint32_t i = 0;
- identifierp = true;
- while (identifierp && i < size) {
- char ch = *ptr++;
- ++i;
- if (tolower(ch) != ch || !ktok_is_subsequent(ch))
- identifierp = false;
- }
+ char *ptr = buf;
+ uint32_t i = 0;
+ identifierp = true;
+ while (identifierp && i < size) {
+ char ch = *ptr++;
+ ++i;
+ if (tolower(ch) != ch || !ktok_is_subsequent(ch))
+ identifierp = false;
+ }
} else
- identifierp = false;
+ identifierp = false;
if (identifierp) {
- /* no problem, just a simple string */
- kw_printf(K, "%s", buf);
- return;
+ /* no problem, just a simple string */
+ kw_printf(K, "%s", buf);
+ return;
}
/*
@@ -281,43 +281,43 @@ void kw_print_symbol_buf(klisp_State *K, char *buf, uint32_t size)
kw_printf(K, "|");
while (i < size) {
- /* find the longest printf-able substring to avoid calling printf
- for every char */
- for (ptr = buf;
- i < size && *ptr != '\0' &&
- (*ptr >= 32 && *ptr < 127) &&
- (*ptr != '\\' && *ptr != '|');
- i++, ptr++)
- ;
-
- /* NOTE: this work even if ptr == buf (which can only happen the
- first or last time) */
- char ch = *ptr;
- *ptr = '\0';
- kw_printf(K, "%s", buf);
- *ptr = ch;
-
- for(; i < size && (*ptr == '\0' || (*ptr < 32 || *ptr >= 127) ||
- (*ptr == '\\' || *ptr == '|'));
- ++i, ptr++) {
- /* This are all ASCII printable characters (including space,
- and exceptuating '\' and '|') */
- char *fmt;
- /* must be uint32_t to support all unicode chars
- in the future */
- uint32_t arg;
- ch = *ptr;
- switch(*ptr) {
- /* regular \ escapes */
- case '|': fmt = "\\%c"; arg = (uint32_t) '|'; break;
- case '\\': fmt = "\\%c"; arg = (uint32_t) '\\'; break;
- /* for the rest of the non printable chars,
- use hex escape */
- default: fmt = "\\x%x;"; arg = (uint32_t) ch; break;
- }
- kw_printf(K, fmt, arg);
- }
- buf = ptr;
+ /* find the longest printf-able substring to avoid calling printf
+ for every char */
+ for (ptr = buf;
+ i < size && *ptr != '\0' &&
+ (*ptr >= 32 && *ptr < 127) &&
+ (*ptr != '\\' && *ptr != '|');
+ i++, ptr++)
+ ;
+
+ /* NOTE: this work even if ptr == buf (which can only happen the
+ first or last time) */
+ char ch = *ptr;
+ *ptr = '\0';
+ kw_printf(K, "%s", buf);
+ *ptr = ch;
+
+ for(; i < size && (*ptr == '\0' || (*ptr < 32 || *ptr >= 127) ||
+ (*ptr == '\\' || *ptr == '|'));
+ ++i, ptr++) {
+ /* This are all ASCII printable characters (including space,
+ and exceptuating '\' and '|') */
+ char *fmt;
+ /* must be uint32_t to support all unicode chars
+ in the future */
+ uint32_t arg;
+ ch = *ptr;
+ switch(*ptr) {
+ /* regular \ escapes */
+ case '|': fmt = "\\%c"; arg = (uint32_t) '|'; break;
+ case '\\': fmt = "\\%c"; arg = (uint32_t) '\\'; break;
+ /* for the rest of the non printable chars,
+ use hex escape */
+ default: fmt = "\\x%x;"; arg = (uint32_t) ch; break;
+ }
+ kw_printf(K, fmt, arg);
+ }
+ buf = ptr;
}
kw_printf(K, "|");
@@ -344,18 +344,18 @@ void kw_clear_marks(klisp_State *K, TValue root)
push_data(K, root);
while(!data_is_empty(K)) {
- TValue obj = get_data(K);
- pop_data(K);
+ TValue obj = get_data(K);
+ pop_data(K);
- if (ttispair(obj)) {
- if (kis_marked(obj)) {
- kunmark(obj);
- push_data(K, kcdr(obj));
- push_data(K, kcar(obj));
- }
- } else if (ttisstring(obj) && (kis_marked(obj))) {
- kunmark(obj);
- }
+ if (ttispair(obj)) {
+ if (kis_marked(obj)) {
+ kunmark(obj);
+ push_data(K, kcdr(obj));
+ push_data(K, kcar(obj));
+ }
+ } else if (ttisstring(obj) && (kis_marked(obj))) {
+ kunmark(obj);
+ }
}
assert(ks_sisempty(K));
}
@@ -377,27 +377,27 @@ void kw_set_initial_marks(klisp_State *K, TValue root)
push_data(K, root);
while(!data_is_empty(K)) {
- TValue obj = get_data(K);
- pop_data(K);
-
- if (ttispair(obj)) {
- if (kis_unmarked(obj)) {
- kmark(obj); /* this mark just means visited */
- push_data(K, kcdr(obj));
- push_data(K, kcar(obj));
- } else {
- /* this mark means it will need a ref number */
- kset_mark(obj, i2tv(-1));
- }
- } else if (ttisstring(obj)) {
- if (kis_unmarked(obj)) {
- kmark(obj); /* this mark just means visited */
- } else {
- /* this mark means it will need a ref number */
- kset_mark(obj, i2tv(-1));
- }
- }
- /* all other types of object don't matter */
+ TValue obj = get_data(K);
+ pop_data(K);
+
+ if (ttispair(obj)) {
+ if (kis_unmarked(obj)) {
+ kmark(obj); /* this mark just means visited */
+ push_data(K, kcdr(obj));
+ push_data(K, kcar(obj));
+ } else {
+ /* this mark means it will need a ref number */
+ kset_mark(obj, i2tv(-1));
+ }
+ } else if (ttisstring(obj)) {
+ if (kis_unmarked(obj)) {
+ kmark(obj); /* this mark just means visited */
+ } else {
+ /* this mark means it will need a ref number */
+ kset_mark(obj, i2tv(-1));
+ }
+ }
+ /* all other types of object don't matter */
}
assert(ks_sisempty(K));
}
@@ -442,14 +442,14 @@ void kw_print_cont_type(klisp_State *K, TValue obj)
Continuation *cont = tv2cont(obj);
const TValue *node = klispH_get(tv2table(K->cont_name_table),
- p2tv(cont->fn));
+ p2tv(cont->fn));
char *type;
if (node == &kfree) {
- type = "?";
+ type = "?";
} else {
- klisp_assert(ttisstring(*node));
- type = kstring_buf(*node);
+ klisp_assert(ttisstring(*node));
+ type = kstring_buf(*node);
}
kw_printf(K, " (%s)", type);
@@ -463,256 +463,256 @@ void kwrite_scalar(klisp_State *K, TValue obj)
{
switch(ttype(obj)) {
case K_TSTRING:
- /* shouldn't happen */
- klisp_assert(0);
- /* avoid warning */
- return;
+ /* shouldn't happen */
+ klisp_assert(0);
+ /* avoid warning */
+ return;
case K_TFIXINT:
- kw_printf(K, "%" PRId32, ivalue(obj));
- break;
+ kw_printf(K, "%" PRId32, ivalue(obj));
+ break;
case K_TBIGINT:
- kw_print_bigint(K, obj);
- break;
+ kw_print_bigint(K, obj);
+ break;
case K_TBIGRAT:
- kw_print_bigrat(K, obj);
- break;
+ kw_print_bigrat(K, obj);
+ break;
case K_TEINF:
- kw_printf(K, "#e%cinfinity", tv_equal(obj, KEPINF)? '+' : '-');
- break;
+ kw_printf(K, "#e%cinfinity", tv_equal(obj, KEPINF)? '+' : '-');
+ break;
case K_TIINF:
- kw_printf(K, "#i%cinfinity", tv_equal(obj, KIPINF)? '+' : '-');
- break;
+ kw_printf(K, "#i%cinfinity", tv_equal(obj, KIPINF)? '+' : '-');
+ break;
case K_TDOUBLE: {
- kw_print_double(K, obj);
- break;
+ kw_print_double(K, obj);
+ break;
}
case K_TRWNPV:
- /* ASK John/TEMP: until John tells me what should this be... */
- kw_printf(K, "#real");
- break;
+ /* ASK John/TEMP: until John tells me what should this be... */
+ kw_printf(K, "#real");
+ break;
case K_TUNDEFINED:
- kw_printf(K, "#undefined");
- break;
+ kw_printf(K, "#undefined");
+ break;
case K_TNIL:
- kw_printf(K, "()");
- break;
+ kw_printf(K, "()");
+ break;
case K_TCHAR: {
- if (K->write_displayp) {
- kw_printf(K, "%c", chvalue(obj));
- } else {
- char ch_buf[16]; /* should be able to contain hex escapes */
- char ch = chvalue(obj);
- char *ch_ptr;
-
- switch (ch) {
- case '\0':
- ch_ptr = "null";
- break;
- case '\a':
- ch_ptr = "alarm";
- break;
- case '\b':
- ch_ptr = "backspace";
- break;
- case '\t':
- ch_ptr = "tab";
- break;
- case '\n':
- ch_ptr = "newline";
- break;
- case '\r':
- ch_ptr = "return";
- break;
- case '\x1b':
- ch_ptr = "escape";
- break;
- case ' ':
- ch_ptr = "space";
- break;
- case '\x7f':
- ch_ptr = "delete";
- break;
- case '\v':
- ch_ptr = "vtab";
- break;
- default: {
- int i = 0;
- if (ch >= 32 && ch < 127) {
- /* printable ASCII range */
- /* (del(127) and space(32) were already considered,
- but it's clearer this way) */
- ch_buf[i++] = ch;
- } else {
- /* use an hex escape for non printing, unnamed chars */
- ch_buf[i++] = 'x';
- int res = snprintf(ch_buf+i, sizeof(ch_buf) - i,
- "%x", ch);
- if (res < 0) {
- /* shouldn't happen, but for the sake of
- completeness... */
- TValue port = K->curr_port;
- if (ttisfport(port)) {
- FILE *file = kfport_file(port);
- clearerr(file); /* clear error for next time */
- }
- kwrite_error(K, "error writing");
- return;
- }
- i += res; /* res doesn't include the '\0' */
- }
- ch_buf[i++] = '\0';
- ch_ptr = ch_buf;
- }
- }
- kw_printf(K, "#\\%s", ch_ptr);
- }
- break;
+ if (K->write_displayp) {
+ kw_printf(K, "%c", chvalue(obj));
+ } else {
+ char ch_buf[16]; /* should be able to contain hex escapes */
+ char ch = chvalue(obj);
+ char *ch_ptr;
+
+ switch (ch) {
+ case '\0':
+ ch_ptr = "null";
+ break;
+ case '\a':
+ ch_ptr = "alarm";
+ break;
+ case '\b':
+ ch_ptr = "backspace";
+ break;
+ case '\t':
+ ch_ptr = "tab";
+ break;
+ case '\n':
+ ch_ptr = "newline";
+ break;
+ case '\r':
+ ch_ptr = "return";
+ break;
+ case '\x1b':
+ ch_ptr = "escape";
+ break;
+ case ' ':
+ ch_ptr = "space";
+ break;
+ case '\x7f':
+ ch_ptr = "delete";
+ break;
+ case '\v':
+ ch_ptr = "vtab";
+ break;
+ default: {
+ int i = 0;
+ if (ch >= 32 && ch < 127) {
+ /* printable ASCII range */
+ /* (del(127) and space(32) were already considered,
+ but it's clearer this way) */
+ ch_buf[i++] = ch;
+ } else {
+ /* use an hex escape for non printing, unnamed chars */
+ ch_buf[i++] = 'x';
+ int res = snprintf(ch_buf+i, sizeof(ch_buf) - i,
+ "%x", ch);
+ if (res < 0) {
+ /* shouldn't happen, but for the sake of
+ completeness... */
+ TValue port = K->curr_port;
+ if (ttisfport(port)) {
+ FILE *file = kfport_file(port);
+ clearerr(file); /* clear error for next time */
+ }
+ kwrite_error(K, "error writing");
+ return;
+ }
+ i += res; /* res doesn't include the '\0' */
+ }
+ ch_buf[i++] = '\0';
+ ch_ptr = ch_buf;
+ }
+ }
+ kw_printf(K, "#\\%s", ch_ptr);
+ }
+ break;
}
case K_TBOOLEAN:
- kw_printf(K, "#%c", bvalue(obj)? 't' : 'f');
- break;
+ kw_printf(K, "#%c", bvalue(obj)? 't' : 'f');
+ break;
case K_TSYMBOL:
- kw_print_symbol(K, obj);
- break;
+ kw_print_symbol(K, obj);
+ break;
case K_TKEYWORD:
- kw_print_keyword(K, obj);
- break;
+ kw_print_keyword(K, obj);
+ break;
case K_TINERT:
- kw_printf(K, "#inert");
- break;
+ kw_printf(K, "#inert");
+ break;
case K_TIGNORE:
- kw_printf(K, "#ignore");
- break;
+ kw_printf(K, "#ignore");
+ break;
/* unreadable objects */
case K_TEOF:
- kw_printf(K, "#[eof]");
- break;
+ kw_printf(K, "#[eof]");
+ break;
case K_TENVIRONMENT:
- kw_printf(K, "#[environment");
- #if KTRACK_NAMES
- if (khas_name(obj)) {
- kw_print_name(K, obj);
- }
- #endif
- kw_printf(K, "]");
- break;
+ kw_printf(K, "#[environment");
+#if KTRACK_NAMES
+ if (khas_name(obj)) {
+ kw_print_name(K, obj);
+ }
+#endif
+ kw_printf(K, "]");
+ break;
case K_TCONTINUATION:
- kw_printf(K, "#[continuation");
- #if KTRACK_NAMES
- if (khas_name(obj)) {
- kw_print_name(K, obj);
- }
- #endif
-
- kw_print_cont_type(K, obj);
-
- #if KTRACK_SI
- if (khas_si(obj))
- kw_print_si(K, obj);
- #endif
- kw_printf(K, "]");
- break;
+ kw_printf(K, "#[continuation");
+#if KTRACK_NAMES
+ if (khas_name(obj)) {
+ kw_print_name(K, obj);
+ }
+#endif
+
+ kw_print_cont_type(K, obj);
+
+#if KTRACK_SI
+ if (khas_si(obj))
+ kw_print_si(K, obj);
+#endif
+ kw_printf(K, "]");
+ break;
case K_TOPERATIVE:
- kw_printf(K, "#[operative");
- #if KTRACK_NAMES
- if (khas_name(obj)) {
- kw_print_name(K, obj);
- }
- #endif
- #if KTRACK_SI
- if (khas_si(obj))
- kw_print_si(K, obj);
- #endif
- kw_printf(K, "]");
- break;
+ kw_printf(K, "#[operative");
+#if KTRACK_NAMES
+ if (khas_name(obj)) {
+ kw_print_name(K, obj);
+ }
+#endif
+#if KTRACK_SI
+ if (khas_si(obj))
+ kw_print_si(K, obj);
+#endif
+ kw_printf(K, "]");
+ break;
case K_TAPPLICATIVE:
- kw_printf(K, "#[applicative");
- #if KTRACK_NAMES
- if (khas_name(obj)) {
- kw_print_name(K, obj);
- }
- #endif
- #if KTRACK_SI
- if (khas_si(obj))
- kw_print_si(K, obj);
- #endif
- kw_printf(K, "]");
- break;
+ kw_printf(K, "#[applicative");
+#if KTRACK_NAMES
+ if (khas_name(obj)) {
+ kw_print_name(K, obj);
+ }
+#endif
+#if KTRACK_SI
+ if (khas_si(obj))
+ kw_print_si(K, obj);
+#endif
+ kw_printf(K, "]");
+ break;
case K_TENCAPSULATION:
- /* TODO try to get the name */
- kw_printf(K, "#[encapsulation]");
- break;
+ /* TODO try to get the name */
+ kw_printf(K, "#[encapsulation]");
+ break;
case K_TPROMISE:
- /* TODO try to get the name */
- kw_printf(K, "#[promise]");
- break;
+ /* TODO try to get the name */
+ kw_printf(K, "#[promise]");
+ break;
case K_TFPORT:
- /* TODO try to get the filename */
- kw_printf(K, "#[%s %s file port",
- kport_is_binary(obj)? "binary" : "textual",
- kport_is_input(obj)? "input" : "output");
- #if KTRACK_NAMES
- if (khas_name(obj)) {
- kw_print_name(K, obj);
- }
- #endif
- kw_printf(K, "]");
- break;
+ /* TODO try to get the filename */
+ kw_printf(K, "#[%s %s file port",
+ kport_is_binary(obj)? "binary" : "textual",
+ kport_is_input(obj)? "input" : "output");
+#if KTRACK_NAMES
+ if (khas_name(obj)) {
+ kw_print_name(K, obj);
+ }
+#endif
+ kw_printf(K, "]");
+ break;
case K_TMPORT:
- kw_printf(K, "#[%s %s port",
- kport_is_binary(obj)? "bytevector" : "string",
- kport_is_input(obj)? "input" : "output");
- #if KTRACK_NAMES
- if (khas_name(obj)) {
- kw_print_name(K, obj);
- }
- #endif
- kw_printf(K, "]");
- break;
+ kw_printf(K, "#[%s %s port",
+ kport_is_binary(obj)? "bytevector" : "string",
+ kport_is_input(obj)? "input" : "output");
+#if KTRACK_NAMES
+ if (khas_name(obj)) {
+ kw_print_name(K, obj);
+ }
+#endif
+ kw_printf(K, "]");
+ break;
case K_TERROR: {
- kw_printf(K, "#[error: ");
+ kw_printf(K, "#[error: ");
- /* TEMP for now show only msg */
- bool saved_displayp = K->write_displayp;
- K->write_displayp = false; /* use "'s and escapes */
- kw_print_string(K, tv2error(obj)->msg);
- K->write_displayp = saved_displayp;
+ /* TEMP for now show only msg */
+ bool saved_displayp = K->write_displayp;
+ K->write_displayp = false; /* use "'s and escapes */
+ kw_print_string(K, tv2error(obj)->msg);
+ K->write_displayp = saved_displayp;
- kw_printf(K, "]");
- break;
+ kw_printf(K, "]");
+ break;
}
case K_TBYTEVECTOR:
- kw_printf(K, "#[bytevector");
- #if KTRACK_NAMES
- if (khas_name(obj)) {
- kw_print_name(K, obj);
- }
- #endif
- kw_printf(K, "]");
- break;
+ kw_printf(K, "#[bytevector");
+#if KTRACK_NAMES
+ if (khas_name(obj)) {
+ kw_print_name(K, obj);
+ }
+#endif
+ kw_printf(K, "]");
+ break;
case K_TVECTOR:
kw_printf(K, "#[vector");
- #if KTRACK_NAMES
+#if KTRACK_NAMES
if (khas_name(obj)) {
kw_print_name(K, obj);
}
- #endif
+#endif
kw_printf(K, "]");
break;
case K_TMODULE:
kw_printf(K, "#[module");
- #if KTRACK_NAMES
+#if KTRACK_NAMES
if (khas_name(obj)) {
kw_print_name(K, obj);
}
- #endif
+#endif
kw_printf(K, "]");
break;
default:
- /* shouldn't happen */
- kwrite_error(K, "unknown object type");
- /* avoid warning */
- return;
+ /* shouldn't happen */
+ kwrite_error(K, "unknown object type");
+ /* avoid warning */
+ return;
}
}
@@ -728,78 +728,78 @@ void kwrite_fsm(klisp_State *K, TValue obj)
bool middle_list = false;
while (!data_is_empty(K)) {
- TValue obj = get_data(K);
- pop_data(K);
-
- if (middle_list) {
- if (ttisnil(obj)) { /* end of list */
- kw_printf(K, ")");
- /* middle_list = true; */
- } else if (ttispair(obj) && ttisboolean(kget_mark(obj))) {
- push_data(K, kcdr(obj));
- push_data(K, kcar(obj));
- kw_printf(K, " ");
- middle_list = false;
- } else { /* improper list is the same as shared ref */
- kw_printf(K, " . ");
- push_data(K, KNIL);
- push_data(K, obj);
- middle_list = false;
- }
- } else { /* if (middle_list) */
- switch(ttype(obj)) {
- case K_TPAIR: {
- TValue mark = kget_mark(obj);
- if (ttisboolean(mark)) { /* simple pair (only once) */
- kw_printf(K, "(");
- push_data(K, kcdr(obj));
- push_data(K, kcar(obj));
- middle_list = false;
- } else if (ivalue(mark) < 0) { /* pair with no assigned # */
- /* TEMP: for now only fixints in shared refs */
- assert(kw_shared_count >= 0);
-
- kset_mark(obj, i2tv(kw_shared_count));
- kw_printf(K, "#%" PRId32 "=(", kw_shared_count);
- kw_shared_count++;
- push_data(K, kcdr(obj));
- push_data(K, kcar(obj));
- middle_list = false;
- } else { /* pair with an assigned number */
- kw_printf(K, "#%" PRId32 "#", ivalue(mark));
- middle_list = true;
- }
- break;
- }
- case K_TSTRING: {
- if (kstring_emptyp(obj)) {
+ TValue obj = get_data(K);
+ pop_data(K);
+
+ if (middle_list) {
+ if (ttisnil(obj)) { /* end of list */
+ kw_printf(K, ")");
+ /* middle_list = true; */
+ } else if (ttispair(obj) && ttisboolean(kget_mark(obj))) {
+ push_data(K, kcdr(obj));
+ push_data(K, kcar(obj));
+ kw_printf(K, " ");
+ middle_list = false;
+ } else { /* improper list is the same as shared ref */
+ kw_printf(K, " . ");
+ push_data(K, KNIL);
+ push_data(K, obj);
+ middle_list = false;
+ }
+ } else { /* if (middle_list) */
+ switch(ttype(obj)) {
+ case K_TPAIR: {
+ TValue mark = kget_mark(obj);
+ if (ttisboolean(mark)) { /* simple pair (only once) */
+ kw_printf(K, "(");
+ push_data(K, kcdr(obj));
+ push_data(K, kcar(obj));
+ middle_list = false;
+ } else if (ivalue(mark) < 0) { /* pair with no assigned # */
+ /* TEMP: for now only fixints in shared refs */
+ assert(kw_shared_count >= 0);
+
+ kset_mark(obj, i2tv(kw_shared_count));
+ kw_printf(K, "#%" PRId32 "=(", kw_shared_count);
+ kw_shared_count++;
+ push_data(K, kcdr(obj));
+ push_data(K, kcar(obj));
+ middle_list = false;
+ } else { /* pair with an assigned number */
+ kw_printf(K, "#%" PRId32 "#", ivalue(mark));
+ middle_list = true;
+ }
+ break;
+ }
+ case K_TSTRING: {
+ if (kstring_emptyp(obj)) {
if (!K->write_displayp)
- kw_printf(K, "\"\"");
- } else {
- TValue mark = kget_mark(obj);
- if (K->write_displayp || ttisboolean(mark)) {
+ kw_printf(K, "\"\"");
+ } else {
+ TValue mark = kget_mark(obj);
+ if (K->write_displayp || ttisboolean(mark)) {
/* simple string (only once) or in display
- (show all strings) */
- kw_print_string(K, obj);
- } else if (ivalue(mark) < 0) { /* string with no assigned # */
- /* TEMP: for now only fixints in shared refs */
- assert(kw_shared_count >= 0);
- kset_mark(obj, i2tv(kw_shared_count));
- kw_printf(K, "#%" PRId32 "=", kw_shared_count);
- kw_shared_count++;
- kw_print_string(K, obj);
- } else { /* string with an assigned number */
- kw_printf(K, "#%" PRId32 "#", ivalue(mark));
- }
- }
- middle_list = true;
- break;
- }
- default:
- kwrite_scalar(K, obj);
- middle_list = true;
- }
- }
+ (show all strings) */
+ kw_print_string(K, obj);
+ } else if (ivalue(mark) < 0) { /* string with no assigned # */
+ /* TEMP: for now only fixints in shared refs */
+ assert(kw_shared_count >= 0);
+ kset_mark(obj, i2tv(kw_shared_count));
+ kw_printf(K, "#%" PRId32 "=", kw_shared_count);
+ kw_shared_count++;
+ kw_print_string(K, obj);
+ } else { /* string with an assigned number */
+ kw_printf(K, "#%" PRId32 "#", ivalue(mark));
+ }
+ }
+ middle_list = true;
+ break;
+ }
+ default:
+ kwrite_scalar(K, obj);
+ middle_list = true;
+ }
+ }
}
assert(ks_sisempty(K));
@@ -838,7 +838,7 @@ void kwrite_simple(klisp_State *K, TValue obj)
** Writer Interface
*/
void kwrite_display_to_port(klisp_State *K, TValue port, TValue obj,
- bool displayp)
+ bool displayp)
{
klisp_assert(ttisport(port));
klisp_assert(kport_is_output(port));
@@ -869,7 +869,7 @@ void kwrite_newline_to_port(klisp_State *K, TValue port)
klisp_assert(kport_is_open(port));
klisp_assert(kport_is_textual(port));
K->curr_port = port; /* this isn't needed but all other
- i/o functions set it */
+ i/o functions set it */
kwrite_char_to_port(K, port, ch2tv('\n'));
}
@@ -880,35 +880,35 @@ void kwrite_char_to_port(klisp_State *K, TValue port, TValue ch)
klisp_assert(kport_is_open(port));
klisp_assert(kport_is_textual(port));
K->curr_port = port; /* this isn't needed but all other
- i/o functions set it */
+ i/o functions set it */
if (ttisfport(port)) {
- FILE *file = kfport_file(port);
- int res = fputc(chvalue(ch), file);
+ FILE *file = kfport_file(port);
+ int res = fputc(chvalue(ch), file);
- if (res == EOF) {
- clearerr(file); /* clear error for next time */
- kwrite_error(K, "error writing char");
- }
+ if (res == EOF) {
+ clearerr(file); /* clear error for next time */
+ kwrite_error(K, "error writing char");
+ }
} else if (ttismport(port)) {
- if (kport_is_binary(port)) {
- /* bytebuffer port */
- if (kmport_off(port) >= kbytevector_size(kmport_buf(port))) {
- kmport_resize_buffer(K, port, kmport_off(port) + 1);
- }
- kbytevector_buf(kmport_buf(port))[kmport_off(port)] = chvalue(ch);
- ++kmport_off(port);
- } else {
- /* string port */
- if (kmport_off(port) >= kstring_size(kmport_buf(port))) {
- kmport_resize_buffer(K, port, kmport_off(port) + 1);
- }
- kstring_buf(kmport_buf(port))[kmport_off(port)] = chvalue(ch);
- ++kmport_off(port);
- }
+ if (kport_is_binary(port)) {
+ /* bytebuffer port */
+ if (kmport_off(port) >= kbytevector_size(kmport_buf(port))) {
+ kmport_resize_buffer(K, port, kmport_off(port) + 1);
+ }
+ kbytevector_buf(kmport_buf(port))[kmport_off(port)] = chvalue(ch);
+ ++kmport_off(port);
+ } else {
+ /* string port */
+ if (kmport_off(port) >= kstring_size(kmport_buf(port))) {
+ kmport_resize_buffer(K, port, kmport_off(port) + 1);
+ }
+ kstring_buf(kmport_buf(port))[kmport_off(port)] = chvalue(ch);
+ ++kmport_off(port);
+ }
} else {
- kwrite_error(K, "unknown port type");
- return;
+ kwrite_error(K, "unknown port type");
+ return;
}
}
@@ -919,36 +919,36 @@ void kwrite_u8_to_port(klisp_State *K, TValue port, TValue u8)
klisp_assert(kport_is_open(port));
klisp_assert(kport_is_binary(port));
K->curr_port = port; /* this isn't needed but all other
- i/o functions set it */
+ i/o functions set it */
if (ttisfport(port)) {
- FILE *file = kfport_file(port);
- int res = fputc(ivalue(u8), file);
+ FILE *file = kfport_file(port);
+ int res = fputc(ivalue(u8), file);
- if (res == EOF) {
- clearerr(file); /* clear error for next time */
- kwrite_error(K, "error writing u8");
- }
+ if (res == EOF) {
+ clearerr(file); /* clear error for next time */
+ kwrite_error(K, "error writing u8");
+ }
} else if (ttismport(port)) {
- if (kport_is_binary(port)) {
- /* bytebuffer port */
- if (kmport_off(port) >= kbytevector_size(kmport_buf(port))) {
- kmport_resize_buffer(K, port, kmport_off(port) + 1);
- }
- kbytevector_buf(kmport_buf(port))[kmport_off(port)] =
- (uint8_t) ivalue(u8);
- ++kmport_off(port);
- } else {
- /* string port */
- if (kmport_off(port) >= kstring_size(kmport_buf(port))) {
- kmport_resize_buffer(K, port, kmport_off(port) + 1);
- }
- kstring_buf(kmport_buf(port))[kmport_off(port)] =
- (char) ivalue(u8);
- ++kmport_off(port);
- }
+ if (kport_is_binary(port)) {
+ /* bytebuffer port */
+ if (kmport_off(port) >= kbytevector_size(kmport_buf(port))) {
+ kmport_resize_buffer(K, port, kmport_off(port) + 1);
+ }
+ kbytevector_buf(kmport_buf(port))[kmport_off(port)] =
+ (uint8_t) ivalue(u8);
+ ++kmport_off(port);
+ } else {
+ /* string port */
+ if (kmport_off(port) >= kstring_size(kmport_buf(port))) {
+ kmport_resize_buffer(K, port, kmport_off(port) + 1);
+ }
+ kstring_buf(kmport_buf(port))[kmport_off(port)] =
+ (char) ivalue(u8);
+ ++kmport_off(port);
+ }
} else {
- kwrite_error(K, "unknown port type");
- return;
+ kwrite_error(K, "unknown port type");
+ return;
}
}
@@ -958,13 +958,13 @@ void kwrite_flush_port(klisp_State *K, TValue port)
klisp_assert(kport_is_output(port));
klisp_assert(kport_is_open(port));
K->curr_port = port; /* this isn't needed but all other
- i/o functions set it */
+ i/o functions set it */
if (ttisfport(port)) { /* only necessary for file ports */
- FILE *file = kfport_file(port);
- klisp_assert(file);
- if ((fflush(file)) == EOF) {
- clearerr(file); /* clear error for next time */
- kwrite_error(K, "error writing");
- }
+ FILE *file = kfport_file(port);
+ klisp_assert(file);
+ if ((fflush(file)) == EOF) {
+ clearerr(file); /* clear error for next time */
+ kwrite_error(K, "error writing");
+ }
}
}
diff --git a/src/kwrite.h b/src/kwrite.h
@@ -14,7 +14,7 @@
** Writer interface
*/
void kwrite_display_to_port(klisp_State *K, TValue port, TValue obj,
- bool displayp);
+ bool displayp);
void kwrite_simple_to_port(klisp_State *K, TValue port, TValue obj);
void kwrite_newline_to_port(klisp_State *K, TValue port);
void kwrite_char_to_port(klisp_State *K, TValue port, TValue ch);
diff --git a/src/tab_to_4spaces.sed b/src/tab_to_4spaces.sed
@@ -0,0 +1,8 @@
+#
+# use on all .k files
+# i.e. sed -i -f tab_to_4spaces.sed tests/*.k
+# Previously a combination of (4 spaces) tabs and spaces were used
+# to attain a 4 (four) space indenting.
+# From now on, no tabs will be used and indenting will,
+# remain at 4 spaces
+s/\ / /g
+\ No newline at end of file
diff --git a/src/tab_to_8spaces.sed b/src/tab_to_8spaces.sed
@@ -0,0 +1,8 @@
+#
+# use on all .c, and .h (but NOT on the Makefile)
+# i.e. sed -i -f tab_to_8spaces.sed *.[ch]
+# Previously a combination of (8 spaces) tabs and spaces were used
+# to attain a 4 (four) space indenting.
+# From now on, no tabs will be used and indenting will,
+# remain at 4 spaces
+s/\ / /g
+\ No newline at end of file
diff --git a/src/tests/booleans.k b/src/tests/booleans.k
@@ -22,8 +22,8 @@
($check-not-predicate (boolean? wrap))
($check-not-predicate (boolean? (call/cc ($lambda (c) c))))
($check-not-predicate (boolean? ($let (((enc . #ignore)
- (make-encapsulation-type)))
- (enc #inert))))
+ (make-encapsulation-type)))
+ (enc #inert))))
($check-not-predicate (boolean? (memoize #inert)))
($check-not-predicate (boolean? 1))
($check-not-predicate (boolean? -1/2))
@@ -87,11 +87,11 @@
;; check tail recursiveness
($let ((p (cons 1 2)))
($check-predicate ($sequence ($and? ($let/cc cont1
- (set-car! p cont1)
- ($and? ($let/cc cont2
- (set-cdr! p cont2)
- #t))))
- (eq? (car p) (cdr p)))))
+ (set-car! p cont1)
+ ($and? ($let/cc cont2
+ (set-cdr! p cont2)
+ #t))))
+ (eq? (car p) (cdr p)))))
($check-predicate (operative? $or?))
($check-predicate ($or? #t))
@@ -104,27 +104,27 @@
($let ((p (cons 1 2)))
($check-predicate ($sequence ($or? ($let/cc cont1
- (set-car! p cont1)
- ($or? ($let/cc cont2
- (set-cdr! p cont2)
- #t))))
- (eq? (car p) (cdr p)))))
+ (set-car! p cont1)
+ ($or? ($let/cc cont2
+ (set-cdr! p cont2)
+ #t))))
+ (eq? (car p) (cdr p)))))
($let ((p (cons 1 2)))
($check-predicate ($sequence ($and? ($let/cc cont1
- (set-car! p cont1)
- ($or? ($let/cc cont2
- (set-cdr! p cont2)
- #t))))
- (eq? (car p) (cdr p)))))
+ (set-car! p cont1)
+ ($or? ($let/cc cont2
+ (set-cdr! p cont2)
+ #t))))
+ (eq? (car p) (cdr p)))))
($let ((p (cons 1 2)))
($check-predicate ($sequence ($or? ($let/cc cont1
- (set-car! p cont1)
- ($and? ($let/cc cont2
- (set-cdr! p cont2)
- #t))))
- (eq? (car p) (cdr p)))))
+ (set-car! p cont1)
+ ($and? ($let/cc cont2
+ (set-cdr! p cont2)
+ #t))))
+ (eq? (car p) (cdr p)))))
;;;
;;; Error Checking and Robustness
diff --git a/src/tests/bytevectors.k b/src/tests/bytevectors.k
@@ -22,17 +22,17 @@
;; TODO: endianess
($define! u16
($let
- ((decompose ($lambda (w) (list (mod w 256) (div w 256)))))
+ ((decompose ($lambda (w) (list (mod w 256) (div w 256)))))
($lambda words
(list->bytevector (apply append (map decompose words))))))
;; TODO: endianess
($define! u32
($let
- ((decompose
- ($lambda (w)
- (list (mod w 256) (mod (div w 256) 256)
- (mod (div w 65536) 256) (div w 16777216)))))
+ ((decompose
+ ($lambda (w)
+ (list (mod w 256) (mod (div w 256) 256)
+ (mod (div w 65536) 256) (div w 16777216)))))
($lambda words
(list->bytevector (apply append (map decompose words))))))
@@ -66,15 +66,15 @@
($check equal? (list->bytevector (list 1 2 3 4)) (u8 1 2 3 4))
($check-predicate (mutable-bytevector? (list->bytevector (list 1 2 3))))
($check-predicate (mutable-bytevector? (list->bytevector
- (copy-es-immutable (list 1 2 3)))))
+ (copy-es-immutable (list 1 2 3)))))
;; XXX bytevector->list
($check-predicate (null? (bytevector->list (u8))))
($check equal? (bytevector->list (u8 1 2 3 4)) (list 1 2 3 4))
($check-predicate (mutable-pair? (bytevector->list (u8 1 2))))
($check-predicate (mutable-pair? (bytevector->list
- (bytevector->immutable-bytevector
- (u8 1 2)))))
+ (bytevector->immutable-bytevector
+ (u8 1 2)))))
;; (R7RS 3rd draft, section 6.3.7) make-bytevector bytevector-length
@@ -95,8 +95,8 @@
;; additional property: destination must be mutable
;;
($let*
- ((v (make-bytevector 10))
- (w (bytevector->immutable-bytevector v)))
+ ((v (make-bytevector 10))
+ (w (bytevector->immutable-bytevector v)))
($check equal? (bytevector-u8-set! v 0 1) #inert)
($check equal? (bytevector-u8-ref v 0) 1)
($check equal? (bytevector-u8-set! v 0 32) #inert)
@@ -121,8 +121,8 @@
($check-predicate (mutable-bytevector? (bytevector-copy (u8 1 2 3))))
($check-predicate
- (mutable-bytevector?
- (bytevector-copy (bytevector->immutable-bytevector (u8 1 2 3)))))
+ (mutable-bytevector?
+ (bytevector-copy (bytevector->immutable-bytevector (u8 1 2 3)))))
;; XXX bytevector-copy!
;; additional property: returns #inert
@@ -135,9 +135,9 @@
($check equal? v (u8 9 9 3 4 5))
($check-error (bytevector-copy! (u8 1 2 3 4 5 6) v))
($check-error
- (bytevector-copy!
- (u8 1)
- (bytevector->immutable-bytevector (u8 1)))))
+ (bytevector-copy!
+ (u8 1)
+ (bytevector->immutable-bytevector (u8 1)))))
;; (R7RS 3rd draft, section 6.3.7) bytevector-copy-partial
@@ -153,8 +153,8 @@
;; additional property: destination must be mutable
;;
($let*
- ((v (make-bytevector 5 9))
- (w (bytevector->immutable-bytevector v)))
+ ((v (make-bytevector 5 9))
+ (w (bytevector->immutable-bytevector v)))
($check equal? (bytevector-copy-partial! (u8 1 2) 0 2 v 0) #inert)
($check equal? v (u8 1 2 9 9 9))
($check equal? (bytevector-copy-partial! (u8 5 6) 1 2 v 4) #inert)
@@ -168,13 +168,13 @@
;; XXX bytevector-u8-fill!
($check-predicate (inert? (bytevector-u8-fill! (u8 1 2) 0)))
($check equal? ($let ((b (u8 1 2 3)))
- (bytevector-u8-fill! b 0)
- b)
- (u8 0 0 0))
+ (bytevector-u8-fill! b 0)
+ b)
+ (u8 0 0 0))
;; XXX bytevector->immutable-bytevector
($check-predicate
- (immutable-bytevector? (bytevector->immutable-bytevector (u8 1 2))))
+ (immutable-bytevector? (bytevector->immutable-bytevector (u8 1 2))))
($check-not-predicate
- (mutable-bytevector? (bytevector->immutable-bytevector (u8 1 2))))
+ (mutable-bytevector? (bytevector->immutable-bytevector (u8 1 2))))
diff --git a/src/tests/characters.k b/src/tests/characters.k
@@ -64,7 +64,7 @@
($check-predicate (char-whitespace? #\space #\newline))
($check-predicate ($false-for-all? char-whitespace? #\0 #\a #\A #\:))
-; TODO ($check-predicate (char-whitespace? #\tab #\return ....))
+ ; TODO ($check-predicate (char-whitespace? #\tab #\return ....))
;; XXX char-upper-case? char-lower-case?
diff --git a/src/tests/check.k b/src/tests/check.k
@@ -15,364 +15,364 @@
;; variants, there is too much duplication and the applicatives are a bit
;; too long.
($provide!
- ($check $check-error check-report check-reset! check-set-mode!
- check-passed? check-mode-off check-mode-summary
- check-mode-report-failed check-mode-report)
- ;; PRIVATE
+ ($check $check-error check-report check-reset! check-set-mode!
+ check-passed? check-mode-off check-mode-summary
+ check-mode-report-failed check-mode-report)
+ ;; PRIVATE
- ;; STATE
+ ;; STATE
- ;; internal count
- ($define! passed 0)
- ($define! failed 0)
- ($define! first-failed #inert) ;; form: (error? . extra-data)
- ;; no error: (#f exp actual expected)
- ;; error: (#t string exp error)
- ;; failed = 0 => first-failed = #inert
+ ;; internal count
+ ($define! passed 0)
+ ($define! failed 0)
+ ($define! first-failed #inert) ;; form: (error? . extra-data)
+ ;; no error: (#f exp actual expected)
+ ;; error: (#t string exp error)
+ ;; failed = 0 => first-failed = #inert
- ;; initial state: report-failed (states are off summary report-failed and
- ;; report)
- ($define! report-on? #t) ; #t except in all states except: off
- ($define! report-fail? #t) ; #t in states: report-failed and report
- ($define! report-pass? #f) ; #t in state: report
+ ;; initial state: report-failed (states are off summary report-failed and
+ ;; report)
+ ($define! report-on? #t) ; #t except in all states except: off
+ ($define! report-fail? #t) ; #t in states: report-failed and report
+ ($define! report-pass? #f) ; #t in state: report
- ;; encapsulation for mode parameter
- ($define! (enc-mode mode? get-mode-params) (make-encapsulation-type))
- ;; /STATE
+ ;; encapsulation for mode parameter
+ ($define! (enc-mode mode? get-mode-params) (make-encapsulation-type))
+ ;; /STATE
- ;; little helper for error catching
- ;; This evaluates expression in the dynamic environment
- ;; If no error occurs it returs #t
- ;; If an there is an error, the handler applicative is called
- ;; in the dynamic environment with the object passed to the error
- ;; continuation as sole argument
- ($define! $without-error?
- ($vau (exp handler) denv
- (guard-dynamic-extent
- ()
- ($lambda ()
- (eval exp denv)
- #t)
- (list (list error-continuation
- ($lambda (error-obj divert)
- (apply (eval handler denv)
- (list error-obj) denv)
- (apply divert #f)))))))
-
- ;; ;; another way to do the same: return a pair of (error? result/error-obj)
- ;; ;; but it is difficult to use because it starts nesting (see $check)
- ;; ($define! $try
- ;; ($vau (exp) denv
- ;; (guard-dynamic-extent
- ;; ()
- ;; ($lambda ()
- ;; (list #t (eval exp denv))
- ;; (list (list error-continuation
- ;; ($lambda (error-obj divert)
- ;; (apply divert (list #f error-obj)))))))))
+ ;; little helper for error catching
+ ;; This evaluates expression in the dynamic environment
+ ;; If no error occurs it returs #t
+ ;; If an there is an error, the handler applicative is called
+ ;; in the dynamic environment with the object passed to the error
+ ;; continuation as sole argument
+ ($define! $without-error?
+ ($vau (exp handler) denv
+ (guard-dynamic-extent
+ ()
+ ($lambda ()
+ (eval exp denv)
+ #t)
+ (list (list error-continuation
+ ($lambda (error-obj divert)
+ (apply (eval handler denv)
+ (list error-obj) denv)
+ (apply divert #f)))))))
+
+ ;; ;; another way to do the same: return a pair of (error? result/error-obj)
+ ;; ;; but it is difficult to use because it starts nesting (see $check)
+ ;; ($define! $try
+ ;; ($vau (exp) denv
+ ;; (guard-dynamic-extent
+ ;; ()
+ ;; ($lambda ()
+ ;; (list #t (eval exp denv))
+ ;; (list (list error-continuation
+ ;; ($lambda (error-obj divert)
+ ;; (apply divert (list #f error-obj)))))))))
-
+
- ($define! check-passed!
- ($let ((env (get-current-environment)))
- ($lambda ()
- ($set! env passed (+ passed 1)))))
+ ($define! check-passed!
+ ($let ((env (get-current-environment)))
+ ($lambda ()
+ ($set! env passed (+ passed 1)))))
- ($define! check-failed/expected!
- ($let ((env (get-current-environment)))
- ($lambda ls
- ($if (zero? failed)
- ($set! env first-failed (cons #f ls))
- #inert)
- ($set! env failed (+ failed 1)))))
+ ($define! check-failed/expected!
+ ($let ((env (get-current-environment)))
+ ($lambda ls
+ ($if (zero? failed)
+ ($set! env first-failed (cons #f ls))
+ #inert)
+ ($set! env failed (+ failed 1)))))
- ($define! check-failed/error!
- ($let ((env (get-current-environment)))
- ($lambda ls
- ($if (zero? failed)
- ($set! env first-failed (cons #t ls))
- #inert)
- ($set! env failed (+ failed 1)))))
-
- ($define! describe-passed
- ($lambda (exp actual)
- (show-exp exp)
- (show-res actual)
- (show-passed 1)))
-
- ($define! describe-failed
- ($lambda (exp actual expected)
- (show-exp exp)
- (show-res actual)
- (show-failed expected)))
-
- ($define! describe-error
- ($lambda (str exp err-obj)
- (display str)
- (show-exp exp)
- (show-error err-obj)))
+ ($define! check-failed/error!
+ ($let ((env (get-current-environment)))
+ ($lambda ls
+ ($if (zero? failed)
+ ($set! env first-failed (cons #t ls))
+ #inert)
+ ($set! env failed (+ failed 1)))))
+
+ ($define! describe-passed
+ ($lambda (exp actual)
+ (show-exp exp)
+ (show-res actual)
+ (show-passed 1)))
+
+ ($define! describe-failed
+ ($lambda (exp actual expected)
+ (show-exp exp)
+ (show-res actual)
+ (show-failed expected)))
+
+ ($define! describe-error
+ ($lambda (str exp err-obj)
+ (display str)
+ (show-exp exp)
+ (show-error err-obj)))
- ($define! describe-first-failed
- ($lambda ()
- ($if (not? (zero? failed))
- ($let (((error? . extra-data) first-failed))
- (apply ($if error?
- describe-error
- describe-failed)
- extra-data))
- #inert)))
+ ($define! describe-first-failed
+ ($lambda ()
+ ($if (not? (zero? failed))
+ ($let (((error? . extra-data) first-failed))
+ (apply ($if error?
+ describe-error
+ describe-failed)
+ extra-data))
+ #inert)))
- ;; show applicatives
- ($define! show-exp
- ($lambda (exp)
- (write exp)
- (display " => ")))
+ ;; show applicatives
+ ($define! show-exp
+ ($lambda (exp)
+ (write exp)
+ (display " => ")))
- ($define! show-res
- ($lambda (res)
- (write res)))
+ ($define! show-res
+ ($lambda (res)
+ (write res)))
- ($define! show-passed
- ($lambda (cases)
- (display "; *** passed ")
- ($if (not? (=? cases 1))
- ($sequence (display "(")
- (display cases)
- (display " cases)"))
- #inert)
- (display "***")
- (newline)))
+ ($define! show-passed
+ ($lambda (cases)
+ (display "; *** passed ")
+ ($if (not? (=? cases 1))
+ ($sequence (display "(")
+ (display cases)
+ (display " cases)"))
+ #inert)
+ (display "***")
+ (newline)))
- ($define! show-failed
- ($lambda (expected)
- (display "; *** failed ***")
- (newline)
- (display " ; expected result: ")
- (write expected)
- (newline)))
+ ($define! show-failed
+ ($lambda (expected)
+ (display "; *** failed ***")
+ (newline)
+ (display " ; expected result: ")
+ (write expected)
+ (newline)))
- ($define! show-error
- ($lambda (err-obj)
- (display "; *** error ***")
- (newline)
- (display "; error object: ")
- (write err-obj)
- (newline)))
- ;; /PRIVATE
+ ($define! show-error
+ ($lambda (err-obj)
+ (display "; *** error ***")
+ (newline)
+ (display "; error object: ")
+ (write err-obj)
+ (newline)))
+ ;; /PRIVATE
- ;; PUBLIC
+ ;; PUBLIC
- ;; general check facility. It always take an equality predicate
- ;; needs to be operative to save the original expression
- ($define! $check
- ($let ((handler (wrap ($vau (error-obj) denv
- ($set! denv error-obj error-obj)))))
- ($vau (test? exp expected) denv
- ($cond ((not? report-on?) #inert)
- ((not? ($without-error? ($define! test? (eval test? denv))
- handler))
- ($let ((error-ls
- (list "error evaling test? applicative: " test?
- error-obj)))
- (apply check-failed/error! error-ls)
- ($if report-fail?
- (apply describe-error error-ls)
- #inert)))
- ((not? ($without-error? ($define! expected (eval expected denv))
- handler))
- ($let ((error-ls
- (list "error evaling expected value: " expected
- error-obj)))
- (apply check-failed/error! error-ls)
- ($if report-fail?
- (apply describe-error error-ls)
- #inert)))
- ((not? ($without-error? ($define! res (eval exp denv)) handler))
- ($let ((error-ls
- (list "error evaling expression: " exp error-obj)))
- (apply check-failed/error! error-ls)
- ($if report-fail?
- (apply describe-error error-ls)
- #inert)))
- ((not? ($without-error? ($define! test-result
- (apply test? (list res expected)))
- handler)) ;; no dyn env here
- ($let ((error-ls
- (list "error evaling (test? exp expected): "
- (list test? exp expected) error-obj)))
- (apply check-failed/error! error-ls)
- ($if report-fail?
- (apply describe-error error-ls)
- #inert)))
- (test-result
- (check-passed!)
- ($if report-pass? (describe-passed exp res) #inert))
- (#t ; test-result = #f
- (check-failed/expected! exp res expected)
- ($if report-fail? (describe-failed exp res expected)
- #inert))))))
+ ;; general check facility. It always take an equality predicate
+ ;; needs to be operative to save the original expression
+ ($define! $check
+ ($let ((handler (wrap ($vau (error-obj) denv
+ ($set! denv error-obj error-obj)))))
+ ($vau (test? exp expected) denv
+ ($cond ((not? report-on?) #inert)
+ ((not? ($without-error? ($define! test? (eval test? denv))
+ handler))
+ ($let ((error-ls
+ (list "error evaling test? applicative: " test?
+ error-obj)))
+ (apply check-failed/error! error-ls)
+ ($if report-fail?
+ (apply describe-error error-ls)
+ #inert)))
+ ((not? ($without-error? ($define! expected (eval expected denv))
+ handler))
+ ($let ((error-ls
+ (list "error evaling expected value: " expected
+ error-obj)))
+ (apply check-failed/error! error-ls)
+ ($if report-fail?
+ (apply describe-error error-ls)
+ #inert)))
+ ((not? ($without-error? ($define! res (eval exp denv)) handler))
+ ($let ((error-ls
+ (list "error evaling expression: " exp error-obj)))
+ (apply check-failed/error! error-ls)
+ ($if report-fail?
+ (apply describe-error error-ls)
+ #inert)))
+ ((not? ($without-error? ($define! test-result
+ (apply test? (list res expected)))
+ handler)) ;; no dyn env here
+ ($let ((error-ls
+ (list "error evaling (test? exp expected): "
+ (list test? exp expected) error-obj)))
+ (apply check-failed/error! error-ls)
+ ($if report-fail?
+ (apply describe-error error-ls)
+ #inert)))
+ (test-result
+ (check-passed!)
+ ($if report-pass? (describe-passed exp res) #inert))
+ (#t ; test-result = #f
+ (check-failed/expected! exp res expected)
+ ($if report-fail? (describe-failed exp res expected)
+ #inert))))))
-;; XXX /work in progress
+ ;; XXX /work in progress
- ;; helpers
- ($define! $check-ec-helper
- ($vau (test?-exp exp expected-exp escape/c) denv
- ;; TODO, add argument-list for errors
- ($cond ((not? ($without-error? ($define! test? (eval test? denv))
- handler))
- ($let ((error-ls
- (list "error evaling test? applicative: " test?
- error-obj)))
- (apply check-failed/error! error-ls)
- ($if report-fail?
- (apply describe-error error-ls)
- #inert)
- (apply-continuation escape/c #inert)))
- ((not? ($without-error? ($define! expected (eval expected denv))
- handler))
- ($let ((error-ls
- (list "error evaling expected value: " expected
- error-obj)))
- (apply check-failed/error! error-ls)
- ($if report-fail?
- (apply describe-error error-ls)
- #inert)
- (apply-continuation escape/c #inert)
- ))
- ((not? ($without-error? ($define! res (eval exp denv)) handler))
- ($let ((error-ls
- (list "error evaling expression: " exp error-obj)))
- (apply check-failed/error! error-ls)
- ($if report-fail?
- (apply describe-error error-ls)
- #inert)
- (apply-continuation escape/c #inert)))
- ((not? ($without-error? ($define! test-result
- (apply test? (list res expected)))
- handler)) ;; no dyn env here
- ($let ((error-ls
- (list "error evaling (test? exp expected): "
- (list test? exp expected) error-obj)))
- (apply check-failed/error! error-ls)
- ($if report-fail?
- (apply describe-error error-ls)
- #inert)
- (apply-continuation escape/c #inert)))
- (test-result
- ; (check-passed!) passed only after all passed
- ; ($if report-pass? (describe-passed exp res) #inert))
- #inert
- (#t ; test-result = #f
- (check-failed/expected! exp res expected)
- ($if report-fail? (describe-failed exp res expected) #inert)
- (apply-continuation escape/c #inert))))))
+ ;; helpers
+ ($define! $check-ec-helper
+ ($vau (test?-exp exp expected-exp escape/c) denv
+ ;; TODO, add argument-list for errors
+ ($cond ((not? ($without-error? ($define! test? (eval test? denv))
+ handler))
+ ($let ((error-ls
+ (list "error evaling test? applicative: " test?
+ error-obj)))
+ (apply check-failed/error! error-ls)
+ ($if report-fail?
+ (apply describe-error error-ls)
+ #inert)
+ (apply-continuation escape/c #inert)))
+ ((not? ($without-error? ($define! expected (eval expected denv))
+ handler))
+ ($let ((error-ls
+ (list "error evaling expected value: " expected
+ error-obj)))
+ (apply check-failed/error! error-ls)
+ ($if report-fail?
+ (apply describe-error error-ls)
+ #inert)
+ (apply-continuation escape/c #inert)
+ ))
+ ((not? ($without-error? ($define! res (eval exp denv)) handler))
+ ($let ((error-ls
+ (list "error evaling expression: " exp error-obj)))
+ (apply check-failed/error! error-ls)
+ ($if report-fail?
+ (apply describe-error error-ls)
+ #inert)
+ (apply-continuation escape/c #inert)))
+ ((not? ($without-error? ($define! test-result
+ (apply test? (list res expected)))
+ handler)) ;; no dyn env here
+ ($let ((error-ls
+ (list "error evaling (test? exp expected): "
+ (list test? exp expected) error-obj)))
+ (apply check-failed/error! error-ls)
+ ($if report-fail?
+ (apply describe-error error-ls)
+ #inert)
+ (apply-continuation escape/c #inert)))
+ (test-result
+ ; (check-passed!) passed only after all passed
+ ; ($if report-pass? (describe-passed exp res) #inert))
+ #inert
+ (#t ; test-result = #f
+ (check-failed/expected! exp res expected)
+ ($if report-fail? (describe-failed exp res expected) #inert)
+ (apply-continuation escape/c #inert))))))
- ($define! $check-ec
- ($let ((handler (wrap ($vau (error-obj) denv
- ($set! denv error-obj error-obj)))))
- ($vau (gens test? exp expected . maybe-arg-list) denv
- ;; TODO add check
- ($define! arg-list ($if (null? maybe-arg-list)
- ()
- (car maybe-arg-list)))
- ($cond ((not? report-on?) #inert)
- ((not? ($without-error? ($define! gen (eval (cons $nested-ec
- gens)
- denv)) handler))
- ($let ((error-ls
- (list "error evaling qualifiers: " gens error-obj)))
- (apply check-failed/error! error-ls)
- ($if report-fail?
- (apply describe-error error-ls)
- #inert)))
- (($let/cc escape/c
- ;; TODO add some security to the continuation
- ;; (like make it one-shot and/or avoid reentry)
- (eval (list do-ec (list gen)
- (list check-ec-helper
- test?-exp exp expected-exp
- escape/c)))
- #t)
- ;; ... TODO passed with n cases
- (check-passed!)
- ($if report-pass? (describe-passed exp res) #inert)
- )
- (#t ;; TODO didn't pass...
- #inert
- )))))
+ ($define! $check-ec
+ ($let ((handler (wrap ($vau (error-obj) denv
+ ($set! denv error-obj error-obj)))))
+ ($vau (gens test? exp expected . maybe-arg-list) denv
+ ;; TODO add check
+ ($define! arg-list ($if (null? maybe-arg-list)
+ ()
+ (car maybe-arg-list)))
+ ($cond ((not? report-on?) #inert)
+ ((not? ($without-error? ($define! gen (eval (cons $nested-ec
+ gens)
+ denv)) handler))
+ ($let ((error-ls
+ (list "error evaling qualifiers: " gens error-obj)))
+ (apply check-failed/error! error-ls)
+ ($if report-fail?
+ (apply describe-error error-ls)
+ #inert)))
+ (($let/cc escape/c
+ ;; TODO add some security to the continuation
+ ;; (like make it one-shot and/or avoid reentry)
+ (eval (list do-ec (list gen)
+ (list check-ec-helper
+ test?-exp exp expected-exp
+ escape/c)))
+ #t)
+ ;; ... TODO passed with n cases
+ (check-passed!)
+ ($if report-pass? (describe-passed exp res) #inert)
+ )
+ (#t ;; TODO didn't pass...
+ #inert
+ )))))
-;; XXX /work in progress
+ ;; XXX /work in progress
- ;; Check that the given expression throws an error
- ;; needs to be operative to save the original expression
- ;; (not in the srfi, probably because of poor specification of error
- ;; signaling in R5RS
- ;; but very useful for checking proper argument checking)
- ($define! $check-error
- ($let ((handler (wrap ($vau (error-obj) denv
- ($set! denv error-obj error-obj)))))
- ($vau (exp) denv
- ($cond ((not? report-on?) #inert)
- (($without-error? ($define! result
- (eval exp denv)) handler)
- ($let ((error-ls
- (list exp result "<ERROR>")))
- (apply check-failed/expected! error-ls)
- ($if report-fail?
- (apply describe-failed error-ls)
- #inert)))
- (#t ;; didn't throw error
- (check-passed!)
- ($if report-pass?
- (describe-passed exp error-obj)
- #inert))))))
+ ;; Check that the given expression throws an error
+ ;; needs to be operative to save the original expression
+ ;; (not in the srfi, probably because of poor specification of error
+ ;; signaling in R5RS
+ ;; but very useful for checking proper argument checking)
+ ($define! $check-error
+ ($let ((handler (wrap ($vau (error-obj) denv
+ ($set! denv error-obj error-obj)))))
+ ($vau (exp) denv
+ ($cond ((not? report-on?) #inert)
+ (($without-error? ($define! result
+ (eval exp denv)) handler)
+ ($let ((error-ls
+ (list exp result "<ERROR>")))
+ (apply check-failed/expected! error-ls)
+ ($if report-fail?
+ (apply describe-failed error-ls)
+ #inert)))
+ (#t ;; didn't throw error
+ (check-passed!)
+ ($if report-pass?
+ (describe-passed exp error-obj)
+ #inert))))))
- ($define! check-report
- ($lambda ()
- ($if report-on?
- ($sequence
- (display "Tests Passed: ")
- (write passed)
- (newline)
- (display "Tests Failed: ")
- (write failed)
- (newline)
- (display "Tests Total: ")
- (write (+ failed passed))
- (newline)
- (describe-first-failed))
- #inert))) ;; state: off don't show anything
+ ($define! check-report
+ ($lambda ()
+ ($if report-on?
+ ($sequence
+ (display "Tests Passed: ")
+ (write passed)
+ (newline)
+ (display "Tests Failed: ")
+ (write failed)
+ (newline)
+ (display "Tests Total: ")
+ (write (+ failed passed))
+ (newline)
+ (describe-first-failed))
+ #inert))) ;; state: off don't show anything
- ;; the modes are an encapsulated object each of
- ;; '(off summary report-failed report)
- ;; is an ecapsulated list of their effect on state variables
- ;; (report-on? report-error? report-pass?)
- ($define! check-mode-off (enc-mode (list #f #f #f)))
- ($define! check-mode-summary (enc-mode (list #t #f #f)))
- ($define! check-mode-report-failed (enc-mode (list #t #t #f)))
- ($define! check-mode-report (enc-mode (list #t #t #t)))
-
- ($define! check-set-mode!
- ($let ((env (get-current-environment)))
- ($lambda (mode)
- ($if (mode? mode)
- ($set! env
- (report-on? report-error? report-pass?)
- (get-mode-params mode))
- (#t (error "$check-set-mode: invalid mode"))))))
-
- ($define! check-reset!
- ($let ((env (get-current-environment)))
- ($lambda ()
- ($set! env passed 0)
- ($set! env failed 0)
- ($set! env first-failed #inert))))
+ ;; the modes are an encapsulated object each of
+ ;; '(off summary report-failed report)
+ ;; is an ecapsulated list of their effect on state variables
+ ;; (report-on? report-error? report-pass?)
+ ($define! check-mode-off (enc-mode (list #f #f #f)))
+ ($define! check-mode-summary (enc-mode (list #t #f #f)))
+ ($define! check-mode-report-failed (enc-mode (list #t #t #f)))
+ ($define! check-mode-report (enc-mode (list #t #t #t)))
+
+ ($define! check-set-mode!
+ ($let ((env (get-current-environment)))
+ ($lambda (mode)
+ ($if (mode? mode)
+ ($set! env
+ (report-on? report-error? report-pass?)
+ (get-mode-params mode))
+ (#t (error "$check-set-mode: invalid mode"))))))
+
+ ($define! check-reset!
+ ($let ((env (get-current-environment)))
+ ($lambda ()
+ ($set! env passed 0)
+ ($set! env failed 0)
+ ($set! env first-failed #inert))))
- ($define! check-passed?
- ($lambda (expected)
- (and? (zero? failed)
- (=? passed expected)))))
+ ($define! check-passed?
+ ($lambda (expected)
+ (and? (zero? failed)
+ (=? passed expected)))))
;; /PUBLIC
diff --git a/src/tests/combiners.k b/src/tests/combiners.k
@@ -35,8 +35,8 @@
($check-not-predicate (operative? wrap))
($check-not-predicate (operative? (call/cc ($lambda (c) c))))
($check-not-predicate (operative? ($let (((enc . #ignore)
- (make-encapsulation-type)))
- (enc #inert))))
+ (make-encapsulation-type)))
+ (enc #inert))))
($check-not-predicate (operative? (memoize #inert)))
($check-not-predicate (operative? 1))
($check-not-predicate (operative? 1.0))
@@ -59,8 +59,8 @@
($check-not-predicate (applicative? $vau))
($check-not-predicate (applicative? (call/cc ($lambda (c) c))))
($check-not-predicate (applicative? ($let (((enc . #ignore)
- (make-encapsulation-type)))
- (enc #inert))))
+ (make-encapsulation-type)))
+ (enc #inert))))
($check-not-predicate (applicative? (memoize #inert)))
($check-not-predicate (applicative? 1))
($check-not-predicate (applicative? 1.0))
@@ -82,8 +82,8 @@
($check-not-predicate (combiner? #inert))
($check-not-predicate (combiner? (call/cc ($lambda (c) c))))
($check-not-predicate (combiner? ($let (((enc . #ignore)
- (make-encapsulation-type)))
- (enc #inert))))
+ (make-encapsulation-type)))
+ (enc #inert))))
($check-not-predicate (combiner? (memoize #inert)))
($check-not-predicate (combiner? 1))
($check-not-predicate (combiner? 1.0))
@@ -106,21 +106,21 @@
($check equal? (($vau ((x . y) (z)) #ignore (list z y x)) (1 . 2) (3)) (list 3 2 1))
($check equal? (($vau ((x y z)) #ignore (list z y x)) (1 2 3)) (list 3 2 1))
($check equal? (($vau ((x y . z)) #ignore (finite-list? z))
- #0=(1 2 3 . #0#)) #f)
+ #0=(1 2 3 . #0#)) #f)
;; test static scope of $vau, define an "inverted" $if and use it in the body
($let (($if ($vau (test a b) denv
- (eval (list $if test b a)
- denv))))
+ (eval (list $if test b a)
+ denv))))
($check eq?
- (($vau () #ignore
- ($if #t 1 2)))
- 2))
+ (($vau () #ignore
+ ($if #t 1 2)))
+ 2))
;; shared structure in ptree (but no shared symbols and no cycles)
($check equal?
- (($vau ((x . #0=(#ignore)) (y . #0#)) #ignore (list x y)) (1 4) (2 5))
- (list 1 2))
+ (($vau ((x . #0=(#ignore)) (y . #0#)) #ignore (list x y)) (1 4) (2 5))
+ (list 1 2))
;; wrap
($check-predicate (applicative? wrap))
@@ -131,13 +131,13 @@
;; unwrap
($check-predicate (applicative? unwrap))
($check-predicate (operative?
- (unwrap (wrap ($vau #ignore #ignore #inert)))))
+ (unwrap (wrap ($vau #ignore #ignore #inert)))))
($check-predicate (applicative?
- (unwrap (wrap (wrap ($vau #ignore #ignore #inert))))))
+ (unwrap (wrap (wrap ($vau #ignore #ignore #inert))))))
($check-predicate (operative?
- (unwrap list)))
+ (unwrap list)))
($check-predicate (applicative?
- (unwrap (wrap list))))
+ (unwrap (wrap list))))
;; $lambda
($check-predicate (applicative? ($lambda #ignore #inert)))
@@ -147,28 +147,28 @@
($check equal? (($lambda (x y) (list y x)) 1 2) (list 2 1))
;; arguments should be eval'ed in the current environment
($check eq?
- (($lambda (x) x) (get-current-environment))
- (get-current-environment))
+ (($lambda (x) x) (get-current-environment))
+ (get-current-environment))
;; parameter trees (generalized parameter lists)
($check equal? (($lambda ((x . y) (z)) (list z y x))
- (cons 1 2) (list 3)) (list 3 2 1))
+ (cons 1 2) (list 3)) (list 3 2 1))
($check equal? (($lambda ((x y z)) (list z y x)) (list 1 2 3)) (list 3 2 1))
($check equal? (($lambda ((x y . z)) (finite-list? z))
- (list . #0=(1 2 3 . #0#))) #f)
+ (list . #0=(1 2 3 . #0#))) #f)
;; test static scope of $lambda, define an "inverted" $if and use it in the body
($let (($if ($vau (test a b) denv
- (eval (list $if test b a)
- denv))))
+ (eval (list $if test b a)
+ denv))))
($check eq?
- (($lambda ()
- ($if #t 1 2)))
- 2))
+ (($lambda ()
+ ($if #t 1 2)))
+ 2))
;; shared structure in ptree (but no shared symbols and no cycles)
($check equal?
- (($lambda ((x . #0=(#ignore)) (y . #0#)) (list x y))
- (list 1 4) (list 2 5))
- (list 1 2))
+ (($lambda ((x . #0=(#ignore)) (y . #0#)) (list x y))
+ (list 1 4) (list 2 5))
+ (list 1 2))
;; apply
($check-predicate (applicative? apply))
@@ -178,136 +178,136 @@
($check eq? (apply list 3) 3)
;; the two argument case uses an empty environment
($check eq? (apply (wrap ($vau #ignore env ($binds? env $vau)))
- #inert)
- #f)
+ #inert)
+ #f)
($let ((empty-env (make-environment)))
($check eq?
- (apply (wrap ($vau #ignore env env)) #inert empty-env)
- empty-env))
+ (apply (wrap ($vau #ignore env env)) #inert empty-env)
+ empty-env))
;; map
($check-predicate (applicative? map))
($check equal? (map + (list 1 2 3 4)) (list 1 2 3 4))
($check equal? (map cons (list 1 2 3 4) (list 10 20 30 40))
- (list (cons 1 10) (cons 2 20) (cons 3 30) (cons 4 40)))
+ (list (cons 1 10) (cons 2 20) (cons 3 30) (cons 4 40)))
($let ((p (cons () ())))
($check eq?
- ($sequence (map (wrap ($vau #ignore env
- (set-car! p env)))
- (list 1))
- (car p))
- (get-current-environment)))
+ ($sequence (map (wrap ($vau #ignore env
+ (set-car! p env)))
+ (list 1))
+ (car p))
+ (get-current-environment)))
($let ((p (cons 0 ())))
($check eq?
- ($sequence (map ($lambda (x)
- (set-car! p (+ (car p) x)))
- (list 1 2 3 4))
- (car p))
- 10))
+ ($sequence (map ($lambda (x)
+ (set-car! p (+ (car p) x)))
+ (list 1 2 3 4))
+ (car p))
+ 10))
($check equal?
- (map ($lambda (x)
- (- 0 x))
- (list 1 . #0=(2 3 4 . #0#)))
- (list -1 . #1=(-2 -3 -4 . #1#)))
+ (map ($lambda (x)
+ (- 0 x))
+ (list 1 . #0=(2 3 4 . #0#)))
+ (list -1 . #1=(-2 -3 -4 . #1#)))
($check equal?
- (map ($lambda ls
- (finite-list? ls))
- . #0=((list 1 2 3 4)
- (list 10 20 30 40)
- . #0#))
- (list #f #f #f #f))
+ (map ($lambda ls
+ (finite-list? ls))
+ . #0=((list 1 2 3 4)
+ (list 10 20 30 40)
+ . #0#))
+ (list #f #f #f #f))
;; string-map
($check-predicate (applicative? string-map))
($check equal? (string-map char-downcase "") "")
($check equal? (string-map char-upcase "abc") "ABC")
($let ((char-max ($lambda chars
- (integer->char
- (apply max
- (map char->integer chars))))))
+ (integer->char
+ (apply max
+ (map char->integer chars))))))
($check equal? (string-map char-max "abc" "ABC" "xyz" "XYZ")
- "xyz")
+ "xyz")
($check equal? (string-map char-max "abc" "ABC" . #0=("xyz" "XYZ". #0#))
- "xyz"))
+ "xyz"))
($let ((p (cons () ())))
($check eq?
- ($sequence (string-map (wrap ($vau #ignore env
- (set-car! p env)
- #\a))
- "a")
- (car p))
- (get-current-environment)))
+ ($sequence (string-map (wrap ($vau #ignore env
+ (set-car! p env)
+ #\a))
+ "a")
+ (car p))
+ (get-current-environment)))
($let ((p (cons 0 ())))
($check eq?
- ($sequence (string-map ($lambda (x)
- (set-car! p (+ (car p) (char->integer x)))
- #\a)
- "abcd")
- (car p))
- (apply + (map char->integer (string->list "abcd")))))
+ ($sequence (string-map ($lambda (x)
+ (set-car! p (+ (car p) (char->integer x)))
+ #\a)
+ "abcd")
+ (car p))
+ (apply + (map char->integer (string->list "abcd")))))
;; vector-map
($check-predicate (applicative? vector-map))
($check equal? (vector-map inert? (vector #inert #ignore #inert))
- (vector #t #f #t))
+ (vector #t #f #t))
($check equal? (vector-map inert? (vector)) (vector))
($check equal? (vector-map max (vector 1 2) .
- #0=((vector 3 4) (vector 5 6). #0#))
- (vector 5 6))
+ #0=((vector 3 4) (vector 5 6). #0#))
+ (vector 5 6))
($let ((p (cons () ())))
($check eq?
- ($sequence (vector-map (wrap ($vau #ignore env
- (set-car! p env)))
- (vector 1))
- (car p))
- (get-current-environment)))
+ ($sequence (vector-map (wrap ($vau #ignore env
+ (set-car! p env)))
+ (vector 1))
+ (car p))
+ (get-current-environment)))
($let ((p (cons 0 ())))
($check eq?
- ($sequence (vector-map ($lambda (x)
- (set-car! p (+ (car p) x)))
- (vector 1 2 3 4))
- (car p))
- 10))
+ ($sequence (vector-map ($lambda (x)
+ (set-car! p (+ (car p) x)))
+ (vector 1 2 3 4))
+ (car p))
+ 10))
;; bytevector-map
($check-predicate (applicative? bytevector-map))
($check equal? (bytevector-map + (bytevector)) (bytevector))
($check equal? (bytevector-map ($lambda (x) (+ x 1)) (bytevector 1 2 3))
- (bytevector 2 3 4))
+ (bytevector 2 3 4))
($check equal? (bytevector-map max (bytevector 1 2) (bytevector 3 4)
- (bytevector 5 6))
- (bytevector 5 6))
+ (bytevector 5 6))
+ (bytevector 5 6))
($check equal? (bytevector-map max (bytevector 1 2) . #0=((bytevector 3 4)
- (bytevector 5 6) . #0#))
- (bytevector 5 6))
+ (bytevector 5 6) . #0#))
+ (bytevector 5 6))
($let ((p (cons () ())))
($check eq?
- ($sequence (bytevector-map (wrap ($vau #ignore env
- (set-car! p env)
- 1))
- (bytevector 1))
- (car p))
- (get-current-environment)))
+ ($sequence (bytevector-map (wrap ($vau #ignore env
+ (set-car! p env)
+ 1))
+ (bytevector 1))
+ (car p))
+ (get-current-environment)))
($let ((p (cons 0 ())))
($check eq?
- ($sequence (bytevector-map ($lambda (x)
- (set-car! p (+ (car p) x))
- 1)
- (bytevector 1 2 3 4))
- (car p))
- 10))
+ ($sequence (bytevector-map ($lambda (x)
+ (set-car! p (+ (car p) x))
+ 1)
+ (bytevector 1 2 3 4))
+ (car p))
+ 10))
;;;
;;; Error Checking and Robustness
@@ -432,16 +432,16 @@
($check-error (vector-map #inert (vector)))
($check-error (vector-map (unwrap +) (vector 1 2 3)))
($check-error (vector-map ($lambda (x) (+ x 1))
- (vector 1 2) (vector 1 2)))
+ (vector 1 2) (vector 1 2)))
($check-error (vector-map ($lambda (x) (+ x 1)) .
- #0=((vector 1 2) . #0#)))
+ #0=((vector 1 2) . #0#)))
;; bytevector-map
($check-error (bytevector-map))
($check-error (bytevector-map +)) ; the list can't be empty
($check-error (bytevector-map + (bytevector 1 2) (bytevector 1 2 3)))
($check-error (bytevector-map + (bytevector 1 2) .
- #0=((bytevector 1 2 3) . #0#)))
+ #0=((bytevector 1 2 3) . #0#)))
($check-error (bytevector-map number->char (bytevector 41 42 43)))
($check-error (bytevector-map + (bytevector 100 200) (bytevector 300 400)))
@@ -452,6 +452,6 @@
($check-error (bytevector-map #inert (bytevector 1 2 3)))
($check-error (bytevector-map (unwrap char-upcase) (bytevector 1 2 3)))
($check-error (bytevector-map ($lambda (x) (+ x 1))
- (bytevector 1 2 3) (bytevector 1 2 3)))
+ (bytevector 1 2 3) (bytevector 1 2 3)))
($check-error (bytevector-map ($lambda (x) (+ x 1)) .
- #0=((bytevector 1 2 3) . #0#)))
+ #0=((bytevector 1 2 3) . #0#)))
diff --git a/src/tests/control.k b/src/tests/control.k
@@ -22,8 +22,8 @@
($check-not-predicate (inert? wrap))
($check-not-predicate (inert? (call/cc ($lambda (c) c))))
($check-not-predicate (inert? ($let (((enc . #ignore)
- (make-encapsulation-type)))
- (enc #inert))))
+ (make-encapsulation-type)))
+ (enc #inert))))
($check-not-predicate (inert? (memoize #inert)))
($check-not-predicate (inert? 1))
($check-not-predicate (inert? 1.0))
@@ -49,9 +49,9 @@
($check eq? ($if #f #t (get-current-environment)) (get-current-environment))
($let ((p (cons () ())))
($check eq? ($if (($vau #ignore env
- (set-car! p env)
- #t)) (car p) #f)
- (get-current-environment)))
+ (set-car! p env)
+ #t)) (car p) #f)
+ (get-current-environment)))
;; $sequence
($check-predicate (operative? $sequence))
@@ -60,16 +60,16 @@
($check eq? ($sequence 1 2 3) 3)
($check eq? ($sequence (get-current-environment)) (get-current-environment))
($check eq? ($sequence #inert #inert (get-current-environment))
- (get-current-environment))
+ (get-current-environment))
($let ((p (cons 0 ())))
($check eq?
- ($let/cc cont
- ($sequence . #0=(($if (=? (car p) 3)
- (apply-continuation cont #t)
- (set-car! p (+ (car p) 1)))
- . #0#)))
- #t))
+ ($let/cc cont
+ ($sequence . #0=(($if (=? (car p) 3)
+ (apply-continuation cont #t)
+ (set-car! p (+ (car p) 1)))
+ . #0#)))
+ #t))
;; $cond
($check-predicate (operative? $cond))
@@ -80,22 +80,22 @@
($check eq? ($cond (#t (get-current-environment))) (get-current-environment))
($let ((p (cons () ())))
($check eq?
- ($cond (#f)
- (($sequence (set-car! p (get-current-environment))
- #t)
- (car p))
- (#f))
- (get-current-environment)))
+ ($cond (#f)
+ (($sequence (set-car! p (get-current-environment))
+ #t)
+ (car p))
+ (#f))
+ (get-current-environment)))
($check eq? ($cond . #0=((#f) (#t 1) . #0#)) 1)
($let ((p (cons 0 ())))
($check eq?
- ($cond . #0=(((=? (car p) 3) 3)
- (($sequence (set-car! p (+ (car p) 1))
- #f)
- 0)
- (#f)
- . #0#))
- 3))
+ ($cond . #0=(((=? (car p) 3) 3)
+ (($sequence (set-car! p (+ (car p) 1))
+ #f)
+ 0)
+ (#f)
+ . #0#))
+ 3))
;; for-each
@@ -104,46 +104,46 @@
($check eq? (for-each cons (list 1 2 3 4) (list 10 20 30 40)) #inert)
($let ((p (cons () ())))
($check eq?
- ($sequence (for-each (wrap ($vau #ignore env
- (set-car! p env)))
- (list 1))
- (car p))
- (get-current-environment)))
+ ($sequence (for-each (wrap ($vau #ignore env
+ (set-car! p env)))
+ (list 1))
+ (car p))
+ (get-current-environment)))
($let ((p (cons 0 ())))
($check eq?
- ($sequence (for-each ($lambda (x)
- (set-car! p (+ (car p) x)))
- (list 1 2 3 4))
- (car p))
- 10))
+ ($sequence (for-each ($lambda (x)
+ (set-car! p (+ (car p) x)))
+ (list 1 2 3 4))
+ (car p))
+ 10))
($let ((p (cons 0 ())))
($check eq?
- ($sequence (for-each ($lambda (x y )
- (set-car! p (+ (car p) x y)))
- (list 1 2 3 4)
- (list 10 20 30 40))
- (car p))
- 110))
+ ($sequence (for-each ($lambda (x y )
+ (set-car! p (+ (car p) x y)))
+ (list 1 2 3 4)
+ (list 10 20 30 40))
+ (car p))
+ 110))
($let ((p (cons 0 ())))
($check eq?
- ($let/cc cont
- (for-each ($lambda (x)
- ($if (=? (car p) 10)
- (apply-continuation cont 10)
- (set-car! p (+ (car p) 1))))
- (list 1 . #0=(2 3 4 . #0#))))
- #inert))
+ ($let/cc cont
+ (for-each ($lambda (x)
+ ($if (=? (car p) 10)
+ (apply-continuation cont 10)
+ (set-car! p (+ (car p) 1))))
+ (list 1 . #0=(2 3 4 . #0#))))
+ #inert))
($let ((p (cons 0 ())))
($check eq?
- ($sequence (for-each ($lambda ls
- (set-car! p (finite-list? ls)))
- . #0=((list 1 2 3 4)
- (list 10 20 30 40)
- . #0#))
- (car p))
- #f))
+ ($sequence (for-each ($lambda ls
+ (set-car! p (finite-list? ls)))
+ . #0=((list 1 2 3 4)
+ (list 10 20 30 40)
+ . #0#))
+ (car p))
+ #f))
;; string-for-each
@@ -153,120 +153,120 @@
($let ((p (cons () ())))
($check eq?
- ($sequence (string-for-each (wrap ($vau #ignore env
- (set-car! p env)))
- "a")
- (car p))
- (get-current-environment)))
+ ($sequence (string-for-each (wrap ($vau #ignore env
+ (set-car! p env)))
+ "a")
+ (car p))
+ (get-current-environment)))
($let ((p (cons 0 ())))
($check eq?
- ($sequence (string-for-each ($lambda (x)
- (set-car! p (+ (car p)
- (char->integer x))))
- "abcd")
- (car p))
- (apply + (map char->integer (string->list "abcd")))))
+ ($sequence (string-for-each ($lambda (x)
+ (set-car! p (+ (car p)
+ (char->integer x))))
+ "abcd")
+ (car p))
+ (apply + (map char->integer (string->list "abcd")))))
($let ((p (cons 0 ())))
($check eq?
- ($sequence (string-for-each ($lambda (x y )
- (set-car! p (+ (car p)
- (char->integer x)
- (char->integer y))))
- "abc"
- "def")
- (car p))
- (apply + (map char->integer (string->list "abcdef")))))
+ ($sequence (string-for-each ($lambda (x y )
+ (set-car! p (+ (car p)
+ (char->integer x)
+ (char->integer y))))
+ "abc"
+ "def")
+ (car p))
+ (apply + (map char->integer (string->list "abcdef")))))
($let ((p (cons 0 ())))
($check eq?
- ($sequence (string-for-each ($lambda ls
- (set-car! p (finite-list? ls)))
- . #0=("abc"
- "def"
- . #0#))
- (car p))
- #f))
+ ($sequence (string-for-each ($lambda ls
+ (set-car! p (finite-list? ls)))
+ . #0=("abc"
+ "def"
+ . #0#))
+ (car p))
+ #f))
;; vector-for-each
($check-predicate (applicative? vector-for-each))
($check eq? (vector-for-each + (vector 1 2 3)) #inert)
($check eq? (vector-for-each <? (vector 1 2) (vector 3 4))
- #inert)
+ #inert)
($let ((p (cons () ())))
($check eq?
- ($sequence (vector-for-each (wrap ($vau #ignore env
- (set-car! p env)))
- (vector 1))
- (car p))
- (get-current-environment)))
+ ($sequence (vector-for-each (wrap ($vau #ignore env
+ (set-car! p env)))
+ (vector 1))
+ (car p))
+ (get-current-environment)))
($let ((p (cons 0 ())))
($check eq?
- ($sequence (vector-for-each ($lambda (x)
- (set-car! p (+ (car p) x)))
- (vector 1 2 3 4))
- (car p))
- 10))
+ ($sequence (vector-for-each ($lambda (x)
+ (set-car! p (+ (car p) x)))
+ (vector 1 2 3 4))
+ (car p))
+ 10))
($let ((p (cons 0 ())))
($check eq?
- ($sequence (vector-for-each ($lambda (x y )
- (set-car! p (+ (car p) x y)))
- (vector 1 2 3 4)
- (vector 10 20 30 40))
- (car p))
- 110))
+ ($sequence (vector-for-each ($lambda (x y )
+ (set-car! p (+ (car p) x y)))
+ (vector 1 2 3 4)
+ (vector 10 20 30 40))
+ (car p))
+ 110))
($let ((p (cons 0 ())))
($check eq?
- ($sequence (vector-for-each ($lambda ls
- (set-car! p (finite-list? ls)))
- . #0=((vector 1 2)
- (vector 3 4)
- . #0#))
- (car p))
- #f))
+ ($sequence (vector-for-each ($lambda ls
+ (set-car! p (finite-list? ls)))
+ . #0=((vector 1 2)
+ (vector 3 4)
+ . #0#))
+ (car p))
+ #f))
;; bytevector-for-each
($check-predicate (applicative? bytevector-for-each))
($check eq? (bytevector-for-each + (bytevector 1 2 3)) #inert)
($check eq? (bytevector-for-each <? (bytevector 1 2) (bytevector 3 4))
- #inert)
+ #inert)
($let ((p (cons () ())))
($check eq?
- ($sequence (bytevector-for-each (wrap ($vau #ignore env
- (set-car! p env)))
- (bytevector 1))
- (car p))
- (get-current-environment)))
+ ($sequence (bytevector-for-each (wrap ($vau #ignore env
+ (set-car! p env)))
+ (bytevector 1))
+ (car p))
+ (get-current-environment)))
($let ((p (cons 0 ())))
($check eq?
- ($sequence (bytevector-for-each ($lambda (x)
- (set-car! p (+ (car p) x)))
- (bytevector 1 2 3 4))
- (car p))
- 10))
+ ($sequence (bytevector-for-each ($lambda (x)
+ (set-car! p (+ (car p) x)))
+ (bytevector 1 2 3 4))
+ (car p))
+ 10))
($let ((p (cons 0 ())))
($check eq?
- ($sequence (bytevector-for-each ($lambda (x y )
- (set-car! p (+ (car p) x y)))
- (bytevector 1 2 3 4)
- (bytevector 10 20 30 40))
- (car p))
- 110))
+ ($sequence (bytevector-for-each ($lambda (x y )
+ (set-car! p (+ (car p) x y)))
+ (bytevector 1 2 3 4)
+ (bytevector 10 20 30 40))
+ (car p))
+ 110))
($let ((p (cons 0 ())))
($check eq?
- ($sequence (bytevector-for-each ($lambda ls
- (set-car! p (finite-list? ls)))
- . #0=((bytevector 1 2)
- (bytevector 3 4)
- . #0#))
- (car p))
- #f))
+ ($sequence (bytevector-for-each ($lambda ls
+ (set-car! p (finite-list? ls)))
+ . #0=((bytevector 1 2)
+ (bytevector 3 4)
+ . #0#))
+ (car p))
+ #f))
;; $when
($check-predicate (operative? $when))
@@ -279,29 +279,29 @@
($let ((p (cons () ())))
($check equal? ($sequence ($when #f (set-car! p 1))
- (car p))
- ()))
+ (car p))
+ ()))
($let ((p (cons () ())))
($check eq? ($sequence ($when ($sequence
- (set-car! p (get-current-environment))
- #f))
- (car p))
- (get-current-environment)))
+ (set-car! p (get-current-environment))
+ #f))
+ (car p))
+ (get-current-environment)))
($let ((p (cons () ())))
($check eq? ($sequence ($when #t (set-car! p (get-current-environment)))
- (car p))
- (get-current-environment)))
+ (car p))
+ (get-current-environment)))
;; check tail recursiveness
($let ((p (cons 1 2)))
($check-predicate ($sequence ($when #t ($let/cc cont1
- (set-car! p cont1)
- ($when #t
- ($let/cc cont2
- (set-cdr! p cont2)))))
- (eq? (car p) (cdr p)))))
+ (set-car! p cont1)
+ ($when #t
+ ($let/cc cont2
+ (set-cdr! p cont2)))))
+ (eq? (car p) (cdr p)))))
;; $unless
($check-predicate (operative? $unless))
@@ -314,29 +314,29 @@
($let ((p (cons () ())))
($check equal? ($sequence ($unless #t (set-car! p 1))
- (car p))
- ()))
+ (car p))
+ ()))
($let ((p (cons () ())))
($check eq? ($sequence ($unless ($sequence
- (set-car! p (get-current-environment))
- #t))
- (car p))
- (get-current-environment)))
+ (set-car! p (get-current-environment))
+ #t))
+ (car p))
+ (get-current-environment)))
($let ((p (cons () ())))
($check eq? ($sequence ($unless #f (set-car! p (get-current-environment)))
- (car p))
- (get-current-environment)))
+ (car p))
+ (get-current-environment)))
;; check tail recursiveness
($let ((p (cons 1 2)))
($check-predicate ($sequence ($unless #f ($let/cc cont1
- (set-car! p cont1)
- ($unless #f
- ($let/cc cont2
- (set-cdr! p cont2)))))
- (eq? (car p) (cdr p)))))
+ (set-car! p cont1)
+ ($unless #f
+ ($let/cc cont2
+ (set-cdr! p cont2)))))
+ (eq? (car p) (cdr p)))))
;;;
;;; Error Checking and Robustness
@@ -421,16 +421,16 @@
($check-error (bytevector-for-each +)) ; the list can't be empty
($check-error (bytevector-for-each <? (bytevector 1 2)
- (bytevector 1 2 3)))
+ (bytevector 1 2 3)))
($check-error (bytevector-for-each + #inert))
($check-error (bytevector-for-each #inert (bytevector 1 2 3)))
($check-error (bytevector-for-each (unwrap char-upcase)
- (bytevector 1 2)))
+ (bytevector 1 2)))
($check-error (bytevector-for-each <? (bytevector 1 2) #inert))
($check-error (bytevector-for-each cons
- (bytevector 1 2 3)))
+ (bytevector 1 2 3)))
;; $when
diff --git a/src/tests/encapsulations.k b/src/tests/encapsulations.k
@@ -5,17 +5,15 @@
;; 8.1.1 make-encapsulation-type
-($let*
- ( ((e1 p1? d1) (make-encapsulation-type))
- ((e2 p2? d2) (make-encapsulation-type))
- (v1 "test")
- (v2 (list 1 2 3))
- (r11 (e1 v1))
- (r12 (e1 v2))
- (r21 (e2 v1))
- (r22 (e2 v2))
- (r11* (e1 v1)))
-
+($let* (((e1 p1? d1) (make-encapsulation-type))
+ ((e2 p2? d2) (make-encapsulation-type))
+ (v1 "test")
+ (v2 (list 1 2 3))
+ (r11 (e1 v1))
+ (r12 (e1 v2))
+ (r21 (e2 v1))
+ (r22 (e2 v2))
+ (r11* (e1 v1)))
($check-not-predicate (equal? e1 e2))
($check-not-predicate (equal? p1? p2?))
($check-not-predicate (equal? d1 d2))
diff --git a/src/tests/environment-mutation.k b/src/tests/environment-mutation.k
@@ -4,5 +4,5 @@
;;; Basic Functionality
;;;
-;; environmen mutation
+;; environment mutation
;; ....
diff --git a/src/tests/environments.k b/src/tests/environments.k
@@ -31,11 +31,11 @@
($check-error (eval 0 (get-current-environment) 2))
($let*
- ((env (make-environment))
- ((encapsulate #ignore #ignore) (make-encapsulation-type))
- (encapsulation (encapsulate 0))
- (promise ($lazy (+ 1 1)))
- (bytevector (make-bytevector 1)))
+ ((env (make-environment))
+ ((encapsulate #ignore #ignore) (make-encapsulation-type))
+ (encapsulation (encapsulate 0))
+ (promise ($lazy (+ 1 1)))
+ (bytevector (make-bytevector 1)))
($check eq? (eval #t env) #t)
($check eq? (eval #inert env) #inert)
($check eq? (eval () env) ())
@@ -65,12 +65,12 @@
($check-predicate (applicative? make-environment))
($check-predicate (environment? (make-environment)))
($let*
- ((x 0)
- (e1 (make-environment))
- (e2 (make-environment (get-current-environment)))
- (e3 (make-environment e1))
- (e4 (make-environment e2))
- (es (list e1 e2 e3 e4)))
+ ((x 0)
+ (e1 (make-environment))
+ (e2 (make-environment (get-current-environment)))
+ (e3 (make-environment e1))
+ (e4 (make-environment e2))
+ (es (list e1 e2 e3 e4)))
($check-not-predicate ($binds? e1 x))
($check-predicate ($binds? e2 x))
($check-not-predicate ($binds? e3 x))
@@ -92,22 +92,22 @@
($check-error ($let ((sym 0 1)) #inert))
($check-predicate
- ($let
- ((a (and?
- (not? ($binds? (get-current-environment) a))
- (not? ($binds? (get-current-environment) b))))
- (b (and?
- (not? ($binds? (get-current-environment) a))
- (not? ($binds? (get-current-environment) b))))
- (f ($lambda ()
- (and?
- (not? ($binds? (get-current-environment) f))
- (not? ($binds? (get-current-environment) g)))))
- (g ($lambda ()
- (and?
- (not? ($binds? (get-current-environment) f))
- (not? ($binds? (get-current-environment) g))))))
- (and? a b (f) (g))))
+ ($let
+ ((a (and?
+ (not? ($binds? (get-current-environment) a))
+ (not? ($binds? (get-current-environment) b))))
+ (b (and?
+ (not? ($binds? (get-current-environment) a))
+ (not? ($binds? (get-current-environment) b))))
+ (f ($lambda ()
+ (and?
+ (not? ($binds? (get-current-environment) f))
+ (not? ($binds? (get-current-environment) g)))))
+ (g ($lambda ()
+ (and?
+ (not? ($binds? (get-current-environment) f))
+ (not? ($binds? (get-current-environment) g))))))
+ (and? a b (f) (g))))
;; 6.7.1 $binds?
@@ -128,141 +128,141 @@
($let ((x 0))
($check-not-predicate
- ($binds? (make-kernel-standard-environment) x)))
+ ($binds? (make-kernel-standard-environment) x)))
;; symbols defined in the Kernel Report
($check-predicate
- ($binds? (make-kernel-standard-environment)
- ;; 4.1 - 4.10
- boolean?
- eq?
- equal?
- symbol?
- inert? $if
- pair? null? cons
- set-car! set-cdr! copy-es-immutable
- environment? ignore? eval make-environment
- $define!
- operative? applicative? $vau wrap unwrap
- ;; 5.1 - 5.10
- $sequence
- list list*
- $vau $lambda
- car cdr
- caar cadr cdar cddr
- caaar caadr cadar caddr cdaar cdadr cddar cdddr
- caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr
- cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr
- apply
- $cond
- get-list-metrics list-tail
- encycle!
- map
- $let
- ;; 6.1 - 6.4, 6.7 - 6.9
- not? and? or? $and? $or?
- combiner?
- length list-ref append list-neighbors filter
- assoc member? finite-list? countable-list? reduce
- append! copy-es assq memq?
- $binds? get-current-environment make-kernel-standard-environment
- $let* $letrec $letrec* $let-redirect $let-safe $remote-eval
- $bindings->environment
- $set! $provide! $import!
- for-each
- ;; 7.1 - 7.3
- continuation? call/cc extend-continuation guard-continuation
- continuation->applicative root-continuation error-continuation
- apply-continuation $let/cc guard-dynamic-extent exit
- ;; 8.1
- make-encapsulation-type
- ;; 9.1
- promise? force $lazy memoize
- ;; 10.1
- make-keyed-dynamic-variable
- ;; 11.1
- make-keyed-static-variable
- ;; 12.1 - 12.10
- number? finite? integer?
- =? <? <=? >=? >?
- + * -
- zero?
- div mod div-and-mod
- div0 mod0 div0-and-mod0
- positive? negative?
- odd? even?
- abs
- max min
- lcm gcd
- exact? inexact? robust? undefined?
- get-real-internal-bounds get-real-exact-bounds
- get-real-internal-primary get-real-exact-primary
- make-inexact
- real->inexact real->exact
- with-strict-arithmetic get-strict-arithmetic?
- ;; not implemented: with-narrow-arithmetic get-narrow-arithmetic?
- rational?
- /
- numerator denominator
- floor ceiling truncate round
- rationalize simplest-rational
- real?
- exp log
- sin cos tan asin acos atan
- sqrt expt
- ;; not implemented: complex?
- ;; not implemented: make-rectangular real-part imag-part
- ;; not implemented: make-polar magnitude angle
- ;; 13.1
- string->symbol
- ;; 15.1 - 15.2
- port?
- input-port? output-port?
- with-input-from-file with-output-to-file
- get-current-input-port get-current-output-port
- open-input-file open-output-file
- close-input-file close-output-file
- read
- write
- call-with-input-file call-with-output-file
- load
- get-module))
+ ($binds? (make-kernel-standard-environment)
+ ;; 4.1 - 4.10
+ boolean?
+ eq?
+ equal?
+ symbol?
+ inert? $if
+ pair? null? cons
+ set-car! set-cdr! copy-es-immutable
+ environment? ignore? eval make-environment
+ $define!
+ operative? applicative? $vau wrap unwrap
+ ;; 5.1 - 5.10
+ $sequence
+ list list*
+ $vau $lambda
+ car cdr
+ caar cadr cdar cddr
+ caaar caadr cadar caddr cdaar cdadr cddar cdddr
+ caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr
+ cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr
+ apply
+ $cond
+ get-list-metrics list-tail
+ encycle!
+ map
+ $let
+ ;; 6.1 - 6.4, 6.7 - 6.9
+ not? and? or? $and? $or?
+ combiner?
+ length list-ref append list-neighbors filter
+ assoc member? finite-list? countable-list? reduce
+ append! copy-es assq memq?
+ $binds? get-current-environment make-kernel-standard-environment
+ $let* $letrec $letrec* $let-redirect $let-safe $remote-eval
+ $bindings->environment
+ $set! $provide! $import!
+ for-each
+ ;; 7.1 - 7.3
+ continuation? call/cc extend-continuation guard-continuation
+ continuation->applicative root-continuation error-continuation
+ apply-continuation $let/cc guard-dynamic-extent exit
+ ;; 8.1
+ make-encapsulation-type
+ ;; 9.1
+ promise? force $lazy memoize
+ ;; 10.1
+ make-keyed-dynamic-variable
+ ;; 11.1
+ make-keyed-static-variable
+ ;; 12.1 - 12.10
+ number? finite? integer?
+ =? <? <=? >=? >?
+ + * -
+ zero?
+ div mod div-and-mod
+ div0 mod0 div0-and-mod0
+ positive? negative?
+ odd? even?
+ abs
+ max min
+ lcm gcd
+ exact? inexact? robust? undefined?
+ get-real-internal-bounds get-real-exact-bounds
+ get-real-internal-primary get-real-exact-primary
+ make-inexact
+ real->inexact real->exact
+ with-strict-arithmetic get-strict-arithmetic?
+ ;; not implemented: with-narrow-arithmetic get-narrow-arithmetic?
+ rational?
+ /
+ numerator denominator
+ floor ceiling truncate round
+ rationalize simplest-rational
+ real?
+ exp log
+ sin cos tan asin acos atan
+ sqrt expt
+ ;; not implemented: complex?
+ ;; not implemented: make-rectangular real-part imag-part
+ ;; not implemented: make-polar magnitude angle
+ ;; 13.1
+ string->symbol
+ ;; 15.1 - 15.2
+ port?
+ input-port? output-port?
+ with-input-from-file with-output-to-file
+ get-current-input-port get-current-output-port
+ open-input-file open-output-file
+ close-input-file close-output-file
+ read
+ write
+ call-with-input-file call-with-output-file
+ load
+ get-module))
;; Additional symbols defined in klisp.
($check-predicate
- ($binds? (make-kernel-standard-environment)
- ;; symbols
- symbol->string
- ;; strings
- string?
- symbol->string
- ;; TODO
- ;; chars
- char?
- char=? char<? char<=? char>=? char>?
- char->integer integer->char
- ;; TODO
- ;; ports
- textual-port? binary-port?
- with-error-to-file
- get-current-error-port
- open-binary-input-file open-binary-output-file
- close-input-port close-output-port close-port
- eof-object?
- read-char peek-char char-ready? write-char
- newline
- display
- read-u8 peek-u8 u8-ready? write-u8
- flush-output-port
- file-exists? delete-file rename-file
- ;; system functions
- current-second current-jiffy jiffies-per-second
- ;; bytevectors
- bytevector?
- ;; error handling
- error system-error-continuation))
+ ($binds? (make-kernel-standard-environment)
+ ;; symbols
+ symbol->string
+ ;; strings
+ string?
+ symbol->string
+ ;; TODO
+ ;; chars
+ char?
+ char=? char<? char<=? char>=? char>?
+ char->integer integer->char
+ ;; TODO
+ ;; ports
+ textual-port? binary-port?
+ with-error-to-file
+ get-current-error-port
+ open-binary-input-file open-binary-output-file
+ close-input-port close-output-port close-port
+ eof-object?
+ read-char peek-char char-ready? write-char
+ newline
+ display
+ read-u8 peek-u8 u8-ready? write-u8
+ flush-output-port
+ file-exists? delete-file rename-file
+ ;; system functions
+ current-second current-jiffy jiffies-per-second
+ ;; bytevectors
+ bytevector?
+ ;; error handling
+ error system-error-continuation))
;; 6.7.4 $let*
@@ -275,34 +275,34 @@
($check-error ($let* ((sym 0 1)) #inert))
($check-predicate
- ($let*
- ((a (and?
- (not? ($binds? (get-current-environment) a))
- (not? ($binds? (get-current-environment) b))
- (not? ($binds? (get-current-environment) c))))
- (b (and?
- ($binds? (get-current-environment) a)
- (not? ($binds? (get-current-environment) b))
- (not? ($binds? (get-current-environment) c))))
- (c (and?
- ($binds? (get-current-environment) a)
- ($binds? (get-current-environment) b)
- (not? ($binds? (get-current-environment) c))))
- (f ($lambda ()
- (and?
- ($binds? (get-current-environment) a)
- ($binds? (get-current-environment) b)
- ($binds? (get-current-environment) c)
- (not? ($binds? (get-current-environment) f))
- (not? ($binds? (get-current-environment) g)))))
- (g ($lambda ()
- (and?
- ($binds? (get-current-environment) a)
- ($binds? (get-current-environment) b)
- ($binds? (get-current-environment) c)
- ($binds? (get-current-environment) f)
- (not? ($binds? (get-current-environment) g))))))
- (and? a b c (f) (g))))
+ ($let*
+ ((a (and?
+ (not? ($binds? (get-current-environment) a))
+ (not? ($binds? (get-current-environment) b))
+ (not? ($binds? (get-current-environment) c))))
+ (b (and?
+ ($binds? (get-current-environment) a)
+ (not? ($binds? (get-current-environment) b))
+ (not? ($binds? (get-current-environment) c))))
+ (c (and?
+ ($binds? (get-current-environment) a)
+ ($binds? (get-current-environment) b)
+ (not? ($binds? (get-current-environment) c))))
+ (f ($lambda ()
+ (and?
+ ($binds? (get-current-environment) a)
+ ($binds? (get-current-environment) b)
+ ($binds? (get-current-environment) c)
+ (not? ($binds? (get-current-environment) f))
+ (not? ($binds? (get-current-environment) g)))))
+ (g ($lambda ()
+ (and?
+ ($binds? (get-current-environment) a)
+ ($binds? (get-current-environment) b)
+ ($binds? (get-current-environment) c)
+ ($binds? (get-current-environment) f)
+ (not? ($binds? (get-current-environment) g))))))
+ (and? a b c (f) (g))))
;; 6.7.5 $letrec
@@ -310,19 +310,19 @@
($check-no-error ($letrec () #inert))
($check-predicate
- ($letrec ((x (not? ($binds? (get-current-environment) x)))) x))
+ ($letrec ((x (not? ($binds? (get-current-environment) x)))) x))
($check-predicate
- ($letrec
- ((f ($lambda ()
- (and?
- ($binds? (get-current-environment) f)
- ($binds? (get-current-environment) g))))
- (g ($lambda ()
- (and?
- ($binds? (get-current-environment) f)
- ($binds? (get-current-environment) g)))))
- (and? (f) (g))))
+ ($letrec
+ ((f ($lambda ()
+ (and?
+ ($binds? (get-current-environment) f)
+ ($binds? (get-current-environment) g))))
+ (g ($lambda ()
+ (and?
+ ($binds? (get-current-environment) f)
+ ($binds? (get-current-environment) g)))))
+ (and? (f) (g))))
;; 6.7.6 $letrec*
@@ -330,33 +330,33 @@
($check equal? ($letrec* () 123) 123)
($check-predicate
- ($letrec* ((x (not? ($binds? (get-current-environment) x)))) x))
+ ($letrec* ((x (not? ($binds? (get-current-environment) x)))) x))
($check-predicate
- ($letrec*
- ((a 1)
- (f ($lambda ()
- (and?
- ($binds? (get-current-environment) a)
- ($binds? (get-current-environment) f)))))
- (f)))
+ ($letrec*
+ ((a 1)
+ (f ($lambda ()
+ (and?
+ ($binds? (get-current-environment) a)
+ ($binds? (get-current-environment) f)))))
+ (f)))
($check-predicate
- ($letrec*
- ((f ($lambda ()
- ($binds? (get-current-environment) f)))
- (g ($lambda ()
- (and?
- ($binds? (get-current-environment) f)
- ($binds? (get-current-environment) g)))))
- (and? (f) (g))))
+ ($letrec*
+ ((f ($lambda ()
+ ($binds? (get-current-environment) f)))
+ (g ($lambda ()
+ (and?
+ ($binds? (get-current-environment) f)
+ ($binds? (get-current-environment) g)))))
+ (and? (f) (g))))
($check-predicate
- ($letrec*
- ((a 1)
- (b 2)
- (f ($lambda () ($binds? (get-current-environment) f))))
- (f)))
+ ($letrec*
+ ((a 1)
+ (b 2)
+ (f ($lambda () ($binds? (get-current-environment) f))))
+ (f)))
;; 6.7.7 $let-redirect
@@ -364,8 +364,8 @@
($check equal? ($let-redirect (make-environment) () 42) 42)
($let
- ((a 1)
- (env ($let ((a 2)) (get-current-environment))))
+ ((a 1)
+ (env ($let ((a 2)) (get-current-environment))))
($check equal? ($let-redirect (get-current-environment) () a) 1)
($check equal? ($let-redirect env () a) 2)
($check equal? ($let-redirect env ((a 3)) a) 3)
@@ -376,7 +376,7 @@
($check-predicate (operative? $let-safe))
($check equal? ($let-safe () 42) 42)
($let
- (($lambda 42))
+ (($lambda 42))
($check equal? ($let-safe ((x $lambda)) (($lambda () x))) 42)
($check-error ($let ((x $lambda)) (($lambda () x)))))
@@ -386,8 +386,8 @@
($check equal? ($remote-eval 42 (make-environment)) 42)
($let
- ((e0 (make-kernel-standard-environment))
- (e1 ($let ((or? not?)) (get-current-environment))))
+ ((e0 (make-kernel-standard-environment))
+ (e1 ($let ((or? not?)) (get-current-environment))))
($check equal? ($remote-eval (or? #t) e0) #t)
($check equal? ($remote-eval (or? #t) e1) #f))
@@ -396,7 +396,7 @@
($check-predicate (operative? $bindings->environment))
($check-predicate (environment? ($bindings->environment)))
($let
- ((env ($bindings->environment (a 1) (b 2))))
+ ((env ($bindings->environment (a 1) (b 2))))
($check-predicate ($binds? env a b))
($check equal? (eval ($quote a) env) 1)
($check equal? (eval ($quote b) env) 2))
diff --git a/src/tests/eq-equal.k b/src/tests/eq-equal.k
@@ -33,8 +33,8 @@
($check-predicate (eq? wrap))
($check-predicate (eq? (call/cc ($lambda (c) c))))
($check-predicate (eq? ($let (((enc . #ignore)
- (make-encapsulation-type)))
- (enc #inert))))
+ (make-encapsulation-type)))
+ (enc #inert))))
($check-predicate (eq? (memoize #inert)))
($check-predicate (eq? 1))
($check-predicate (eq? -1/2))
@@ -63,8 +63,8 @@
($check-predicate (equal? wrap))
($check-predicate (equal? (call/cc ($lambda (c) c))))
($check-predicate (equal? ($let (((enc . #ignore)
- (make-encapsulation-type)))
- (enc #inert))))
+ (make-encapsulation-type)))
+ (enc #inert))))
($check-predicate (equal? (memoize #inert)))
($check-predicate (equal? 1))
($check-predicate (equal? -1/2))
@@ -98,8 +98,8 @@
($let/cc c
($check-predicate (eq? c c)))
($let* (((enc . #ignore)
- (make-encapsulation-type))
- (e (enc #inert)))
+ (make-encapsulation-type))
+ (e (enc #inert)))
($check-predicate (eq? e e))
($check-not-predicate (eq? e (enc #inert))))
($let ((p (memoize #inert)))
@@ -137,7 +137,7 @@
($check-predicate ($let/cc c (equal? c c)))
($let* (((enc . #ignore)
- (make-encapsulation-type))
+ (make-encapsulation-type))
(e (enc #inert)))
($check-predicate (equal? e e))
($check-not-predicate (equal? e (enc #inert))))
@@ -202,63 +202,63 @@
($check-not-predicate (equal? (list 1 2) (list 3 4)))
($check-predicate
- ($let ((p1 (list 1 2 1 2))
- (p2 (list 1 2)))
- (encycle! p1 2 2)
- (encycle! p2 0 2)
- (equal? p1 p2)))
+ ($let ((p1 (list 1 2 1 2))
+ (p2 (list 1 2)))
+ (encycle! p1 2 2)
+ (encycle! p2 0 2)
+ (equal? p1 p2)))
($check-predicate
- ($let* ((L1 (list 1))
- (L2 (list L1))
- (L3 (list L1 L2)))
- (equal? L3 (list (list 1) (list (list 1))))))
+ ($let* ((L1 (list 1))
+ (L2 (list L1))
+ (L3 (list L1 L2)))
+ (equal? L3 (list (list 1) (list (list 1))))))
($check-not-predicate
- ($let* ((L1 (list 1))
- (L2 (list L1))
- (L3 (list L1 L2)))
- (equal? L3 (list (list 1) (list (list 2))))))
+ ($let* ((L1 (list 1))
+ (L2 (list L1))
+ (L3 (list L1 L2)))
+ (equal? L3 (list (list 1) (list (list 2))))))
($check-predicate
- ($let* ((a (cons #t 0))
- (b (cons #f 0))
- (c (cons #t 0))
- (d (cons #f 0)))
- (set-cdr! a b)
- (set-cdr! b c)
- (set-cdr! c d)
- (set-cdr! d a)
- (equal? a c)))
+ ($let* ((a (cons #t 0))
+ (b (cons #f 0))
+ (c (cons #t 0))
+ (d (cons #f 0)))
+ (set-cdr! a b)
+ (set-cdr! b c)
+ (set-cdr! c d)
+ (set-cdr! d a)
+ (equal? a c)))
($check-not-predicate
- ($let* ((a (cons #t 0))
- (b (cons #f 0))
- (c (cons #t 0))
- (d (cons #f 0)))
- (set-cdr! a b)
- (set-cdr! b c)
- (set-cdr! c d)
- (set-cdr! d a)
- (equal? a b)))
+ ($let* ((a (cons #t 0))
+ (b (cons #f 0))
+ (c (cons #t 0))
+ (d (cons #f 0)))
+ (set-cdr! a b)
+ (set-cdr! b c)
+ (set-cdr! c d)
+ (set-cdr! d a)
+ (equal? a b)))
($check-predicate
- ($let* ((a (list 1 5))
- (b (list a 5))
- (c (list b 5))
- (x (list 1 5)))
- (set-car! a c)
- (set-car! x x)
- (equal? a x)))
+ ($let* ((a (list 1 5))
+ (b (list a 5))
+ (c (list b 5))
+ (x (list 1 5)))
+ (set-car! a c)
+ (set-car! x x)
+ (equal? a x)))
($check-not-predicate
- ($let* ((a (list 1 5))
- (b (list a 555))
- (c (list b 5))
- (x (list 1 5)))
- (set-car! a c)
- (set-car! x x)
- (equal? a x)))
+ ($let* ((a (list 1 5))
+ (b (list a 555))
+ (c (list b 5))
+ (x (list 1 5)))
+ (set-car! a c)
+ (set-car! x x)
+ (equal? a x)))
($check-predicate ($let ((v (vector 1 2 3))) (equal? v v)))
($check-predicate (equal? (vector 1 2 3) (vector 1 2 3)))
@@ -267,89 +267,89 @@
($check-not-predicate (equal? (vector 1 2 3) (vector 2 3)))
($check equal?
- ($let ((v (vector 1 2)) (w (vector 1 3)))
- (list (equal? v w) (equal? v w) (equal? v w) (equal? v w)))
- (list #f #f #f #f))
+ ($let ((v (vector 1 2)) (w (vector 1 3)))
+ (list (equal? v w) (equal? v w) (equal? v w) (equal? v w)))
+ (list #f #f #f #f))
($check-predicate
- ($let* ((a (make-vector 100 1))
- (b (make-vector 100 1))
- (v (make-vector 100 a))
- (w (make-vector 100 b)))
- (equal? v w)))
+ ($let* ((a (make-vector 100 1))
+ (b (make-vector 100 1))
+ (v (make-vector 100 a))
+ (w (make-vector 100 b)))
+ (equal? v w)))
($check-not-predicate
- ($let* ((a (make-vector 100 1))
- (b (make-vector 100 1))
- (c (make-vector 100 1))
- (v (make-vector 100 a))
- (w (make-vector 100 b)))
- (vector-set! c 50 2)
- (vector-set! v 50 c)
- (equal? v w)))
+ ($let* ((a (make-vector 100 1))
+ (b (make-vector 100 1))
+ (c (make-vector 100 1))
+ (v (make-vector 100 a))
+ (w (make-vector 100 b)))
+ (vector-set! c 50 2)
+ (vector-set! v 50 c)
+ (equal? v w)))
($check-not-predicate
- ($let ((v (make-vector 100000 #f))
- (w (make-vector 100000 #f)))
- (vector-set! v 50000 #t)
- (equal? v w)))
+ ($let ((v (make-vector 100000 #f))
+ (w (make-vector 100000 #f)))
+ (vector-set! v 50000 #t)
+ (equal? v w)))
($check-predicate
- ($let* ((v1 (vector 1))
- (v2 (vector 1 v1))
- (v3 (vector 1 v1 v2)))
- (equal?
- v3
- (vector 1 (vector 1) (vector 1 (vector 1))))))
+ ($let* ((v1 (vector 1))
+ (v2 (vector 1 v1))
+ (v3 (vector 1 v1 v2)))
+ (equal?
+ v3
+ (vector 1 (vector 1) (vector 1 (vector 1))))))
($check-not-predicate
- ($let* ((v1 (vector 1))
- (v2 (vector 1 v1))
- (v3 (vector 1 v1 v2)))
- (equal?
- v3
- (vector 1 (vector 2) (vector 1 (vector 1))))))
+ ($let* ((v1 (vector 1))
+ (v2 (vector 1 v1))
+ (v3 (vector 1 v1 v2)))
+ (equal?
+ v3
+ (vector 1 (vector 2) (vector 1 (vector 1))))))
($check-predicate
- ($let* ((a (vector 1 5))
- (b (vector a 5))
- (c (vector b 5))
- (x (vector 1 5)))
- (vector-set! a 0 c)
- (vector-set! x 0 x)
- (equal? a x)))
+ ($let* ((a (vector 1 5))
+ (b (vector a 5))
+ (c (vector b 5))
+ (x (vector 1 5)))
+ (vector-set! a 0 c)
+ (vector-set! x 0 x)
+ (equal? a x)))
($check-not-predicate
- ($let* ((a (vector 1 5))
- (b (vector a 555))
- (c (vector b 5))
- (x (vector 1 5)))
- (vector-set! a 0 c)
- (vector-set! x 0 x)
- (equal? a x)))
+ ($let* ((a (vector 1 5))
+ (b (vector a 555))
+ (c (vector b 5))
+ (x (vector 1 5)))
+ (vector-set! a 0 c)
+ (vector-set! x 0 x)
+ (equal? a x)))
($check-predicate
- ($let* ((a (list 0 0 0))
- (b (list 0 0 0))
- (c (list 0 0 0))
- (v (vector a b c))
- (w (vector b a c)))
- (set-car! a b)
- (set-car! b c)
- (set-car! c a)
- (equal? v w)))
+ ($let* ((a (list 0 0 0))
+ (b (list 0 0 0))
+ (c (list 0 0 0))
+ (v (vector a b c))
+ (w (vector b a c)))
+ (set-car! a b)
+ (set-car! b c)
+ (set-car! c a)
+ (equal? v w)))
($check-not-predicate
- ($let* ((a (list 0 0 1))
- (b (list 0 0 2))
- (c (list 0 0 3))
- (v (vector a b c))
- (w (vector b a c)))
- (set-car! a b)
- (set-car! b c)
- (set-car! c a)
- (equal? v w)))
+ ($let* ((a (list 0 0 1))
+ (b (list 0 0 2))
+ (c (list 0 0 3))
+ (v (vector a b c))
+ (w (vector b a c)))
+ (set-car! a b)
+ (set-car! b c)
+ (set-car! c a)
+ (equal? v w)))
;;
;; two-argument equal? - different argument types
diff --git a/src/tests/error.k b/src/tests/error.k
@@ -10,18 +10,18 @@
;; XXX error-object? error-object-message error-object-irritants
;;
($let*
- ( (capture-error-object
- ($lambda (proc)
- (guard-dynamic-extent
- ()
- proc
- (list (list error-continuation
- ($lambda (obj divert)
- (apply divert obj)))))))
- (e1 (capture-error-object ($lambda () (error "a"))))
- (e2 (capture-error-object ($lambda () (error "b" 1 2 3))))
- (e3 (capture-error-object ($lambda () (error))))
- (e4 (capture-error-object ($lambda () (error 1)))))
+ ( (capture-error-object
+ ($lambda (proc)
+ (guard-dynamic-extent
+ ()
+ proc
+ (list (list error-continuation
+ ($lambda (obj divert)
+ (apply divert obj)))))))
+ (e1 (capture-error-object ($lambda () (error "a"))))
+ (e2 (capture-error-object ($lambda () (error "b" 1 2 3))))
+ (e3 (capture-error-object ($lambda () (error))))
+ (e4 (capture-error-object ($lambda () (error 1)))))
($check-predicate (error-object? e1 e2 e3))
($check-not-predicate (error-object? ""))
@@ -39,10 +39,10 @@
($check equal? (error-object-irritants e1) ())
($check equal? (error-object-irritants e2) (list 1 2 3))
($check equal? (error-object-irritants e3) ())
-;; error now uses the standard binding constructs from kghelper
-;; for now they don't encapsulate any data in the error, but
-;; they will in the future
-;; ($check equal? (error-object-irritants e4) (list 1))
+ ;; error now uses the standard binding constructs from kghelper
+ ;; for now they don't encapsulate any data in the error, but
+ ;; they will in the future
+ ;; ($check equal? (error-object-irritants e4) (list 1))
($check-error (error-object-irritants))
($check-error (error-object-irritants e1 e2))
@@ -53,20 +53,20 @@
($check-predicate (continuation? system-error-continuation))
($let*
- ( (catch-system-error
- ($lambda (proc)
- (guard-dynamic-extent
- ()
- proc
- (list (list system-error-continuation
- ($lambda (obj divert)
- ($let
- ( ( ((service code message errno) . tail)
- (error-object-irritants obj)))
- (apply divert (list* service code tail))))))))))
+ ( (catch-system-error
+ ($lambda (proc)
+ (guard-dynamic-extent
+ ()
+ proc
+ (list (list system-error-continuation
+ ($lambda (obj divert)
+ ($let
+ ( ( ((service code message errno) . tail)
+ (error-object-irritants obj)))
+ (apply divert (list* service code tail))))))))))
- ($check equal?
- (catch-system-error
- ($lambda ()
- (rename-file "nonexistent-file-name" "other-file-name")))
- (list "rename" "ENOENT" "nonexistent-file-name" "other-file-name")))
+ ($check equal?
+ (catch-system-error
+ ($lambda ()
+ (rename-file "nonexistent-file-name" "other-file-name")))
+ (list "rename" "ENOENT" "nonexistent-file-name" "other-file-name")))
diff --git a/src/tests/keyed-variables.k b/src/tests/keyed-variables.k
@@ -8,10 +8,10 @@
($check-error (make-keyed-dynamic-variable #f))
($let*
- ( ((b1 a1) (make-keyed-dynamic-variable))
- ((b2 a2) (make-keyed-dynamic-variable))
- (r1 ($lambda () (a1)))
- (r2 ($lambda () (a2))))
+ ( ((b1 a1) (make-keyed-dynamic-variable))
+ ((b2 a2) (make-keyed-dynamic-variable))
+ (r1 ($lambda () (a1)))
+ (r2 ($lambda () (a2))))
($check-predicate (applicative? b1))
($check-predicate (applicative? a1))
($check-error (b1 1 "not-a-combiner"))
@@ -22,9 +22,9 @@
($check-not-predicate (equal? b1 b2))
($check-not-predicate (equal? a1 a2))
($check-predicate
- (b1 1 ($vau () denv (not? ($binds? denv +)))))
+ (b1 1 ($vau () denv (not? ($binds? denv +)))))
($check-not-predicate
- (b1 1 ($vau () e1 (b2 2 ($vau () e2 (equal? e1 e2))))))
+ (b1 1 ($vau () e1 (b2 2 ($vau () e2 (equal? e1 e2))))))
($check equal? (b1 "value" ($lambda () "result")) "result")
($check equal? (b1 0 r1) 0)
@@ -40,26 +40,26 @@
($check-error (make-keyed-static-variable #f))
($let*
- ( ((b1 a1) (make-keyed-static-variable))
- ((b2 a2) (make-keyed-static-variable))
- (e11 (b1 1 (get-current-environment)))
- (e12 (b1 2 (get-current-environment)))
- (e21 (b2 1 (get-current-environment)))
- (e22 (b2 2 (get-current-environment)))
- (e11* (b1 1 (get-current-environment)))
- (r11 (eval ($quote ($lambda (a) (a))) e11))
- (r12 (eval ($quote ($lambda (a) (a))) e12))
- (r11_13
- (eval
+ ( ((b1 a1) (make-keyed-static-variable))
+ ((b2 a2) (make-keyed-static-variable))
+ (e11 (b1 1 (get-current-environment)))
+ (e12 (b1 2 (get-current-environment)))
+ (e21 (b2 1 (get-current-environment)))
+ (e22 (b2 2 (get-current-environment)))
+ (e11* (b1 1 (get-current-environment)))
+ (r11 (eval ($quote ($lambda (a) (a))) e11))
+ (r12 (eval ($quote ($lambda (a) (a))) e12))
+ (r11_13
+ (eval
($quote
- ($let ((e13 (b1 3 (get-current-environment))))
- (eval ($quote ($lambda (a) (a))) e13)))
+ ($let ((e13 (b1 3 (get-current-environment))))
+ (eval ($quote ($lambda (a) (a))) e13)))
e11))
- (r11_22
- (eval
+ (r11_22
+ (eval
($quote
- ($let ((e22 (b2 2 (get-current-environment))))
- (eval ($quote ($lambda (a) (a))) e22)))
+ ($let ((e22 (b2 2 (get-current-environment))))
+ (eval ($quote ($lambda (a) (a))) e22)))
e11)))
($check-predicate (applicative? b1))
($check-predicate (applicative? a1))
diff --git a/src/tests/keywords.k b/src/tests/keywords.k
@@ -20,8 +20,8 @@
($check-not-predicate (keyword? wrap))
($check-not-predicate (keyword? (call/cc ($lambda (c) c))))
($check-not-predicate (keyword? ($let (((enc . #ignore)
- (make-encapsulation-type)))
- (enc #inert))))
+ (make-encapsulation-type)))
+ (enc #inert))))
($check-not-predicate (keyword? (memoize #inert)))
($check-not-predicate (keyword? 1))
($check-not-predicate (keyword? 1.0))
@@ -51,7 +51,7 @@
($check-predicate (applicative? symbol->keyword))
($check equal? (symbol->keyword ((unwrap list) . keyword)) #:keyword)
($check equal? (keyword->symbol (symbol->keyword ((unwrap list) . keyword)))
- ((unwrap list) . keyword))
+ ((unwrap list) . keyword))
;;;
;;; Eq?-ness & Equal?-ness
diff --git a/src/tests/memory-ports.k b/src/tests/memory-ports.k
@@ -72,11 +72,11 @@
($check-predicate (eof-object? (read-u8 p))))
($let*
- ((v (make-bytevector 3 0))
- (p ($sequence
- (bytevector-u8-set! v 0 2)
- (bytevector-u8-set! v 1 129)
- (open-input-bytevector v))))
+ ((v (make-bytevector 3 0))
+ (p ($sequence
+ (bytevector-u8-set! v 0 2)
+ (bytevector-u8-set! v 1 129)
+ (open-input-bytevector v))))
($check equal? (read-u8 p) 2)
($check equal? (peek-u8 p) 129)
($check equal? (read-u8 p) 129)
diff --git a/src/tests/numbers.k b/src/tests/numbers.k
@@ -24,8 +24,8 @@
;; Other bugs:
;;
;; - evaluating
-;;
-;; ($check equal? (round -1.1) -1)
+;;
+;; ($check equal? (round -1.1) -1)
;; freezes the interpreter
;;
@@ -171,8 +171,8 @@
;; next installement of the report to see if this is changed.
;;
;; Andres Navarro
-;--- ($check equal? (div 10 -7) #undefined) ; FAIL
-;--- ($check equal? (div -10 -7) #undefined) ; FAIL
+ ;--- ($check equal? (div 10 -7) #undefined) ; FAIL
+ ;--- ($check equal? (div -10 -7) #undefined) ; FAIL
($check equal? (mod 10 7) 3)
($check equal? (div-and-mod 10 7) (list 1 3))
@@ -182,13 +182,13 @@
;; contradict the KernelReport.
($check equal? (div-and-mod 123 10) (list 12 3))
-;----- ($check equal? (div-and-mod 123 -10) (list -12 3))
+ ;----- ($check equal? (div-and-mod 123 -10) (list -12 3))
($check equal? (div-and-mod -123 10) (list -13 7))
-;----- ($check equal? (div-and-mod -123 -10) (list 13 7))
+ ;----- ($check equal? (div-and-mod -123 -10) (list 13 7))
($check equal? (div0-and-mod0 123 10) (list 12 3))
-;----- ($check equal? (div0-and-mod0 123 -10) (list -12 3))
+ ;----- ($check equal? (div0-and-mod0 123 -10) (list -12 3))
($check equal? (div0-and-mod0 -123 10) (list -12 -3))
-;----- ($check equal? (div0-and-mod0 -123 -10) (list 12 -3))
+ ;----- ($check equal? (div0-and-mod0 -123 -10) (list 12 -3))
;; 12.5.10 positive? negative?
@@ -257,7 +257,7 @@
;; negative infinity (...)"
;;
;; Andres Navarro
-;; was ($check-predicate (robust? 3.14)) ; FAIL
+;; was ($check-predicate (robust? 3.14)) ; FAIL
($check-not-predicate (robust? #real))
($check-not-predicate (robust? #undefined))
@@ -308,7 +308,7 @@
;; expressible by the formula (sign + or -) mantissa / 2 ^ (-expt)
;;
;; Andres Navarro
-; was ($check-not-predicate (rational? (sqrt 2))) ; FAIL
+ ; was ($check-not-predicate (rational? (sqrt 2))) ; FAIL
($check-not-predicate (rational? #e+infinity))
;; 12.8.2 /
@@ -438,7 +438,7 @@
($check string-ci=? (number->string -10 10) "-10")
($check string-ci=? (number->string 16 16) "10")
($check string-ci=? (number->string -16 16) "-10")
-; default base
+ ; default base
($check string-ci=? (number->string 10) (number->string 10 10))
;; infinities, undefined and reals with no primary value
($check string-ci=? (number->string #undefined) "#undefined")
@@ -453,17 +453,17 @@
($check string-ci=? (number->string #o-21/15 8) "-21/15")
;; bigints
($check string-ci=? (number->string #x1234567890abcdef 16)
- "1234567890abcdef")
+ "1234567890abcdef")
-; only bases 2, 8, 10, 16
+ ; only bases 2, 8, 10, 16
($check-error (number->string 10 3))
-; only numbers
+ ; only numbers
($check-error (number->string #inert))
($check-error (number->string #inert 2))
-; only numbers
+ ; only numbers
($check-error (number->string "2"))
($check-error (number->string "2" 8))
-; only base 10 with inexact numbers
+ ; only base 10 with inexact numbers
($check-error (number->string -1.0 2))
($check-error (number->string 1.25 8))
($check-error (number->string 3.0 16))
@@ -480,7 +480,7 @@
($check =? (string->number "-10" 10) -10)
($check =? (string->number "10" 16) 16)
($check =? (string->number "-10" 16) -16)
-; default base
+ ; default base
($check =? (string->number "10") (string->number "10" 10))
;; infinities, undefined and reals with no primary value
;; #undefined and #real can't be compared with =?
@@ -496,21 +496,21 @@
($check =? (string->number "-21/15" 8) #o-21/15)
;; bigints
($check =? (string->number "1234567890abcdef" 16)
- #x1234567890abcdef)
+ #x1234567890abcdef)
($check =? (string->number "1234567890ABCDEF" 16)
- #x1234567890abcdef)
+ #x1234567890abcdef)
;; doubles
($check =? (string->number "1.25e10") 1.25e10)
($check =? (string->number "-1.25e10" 10) -1.25e10)
-; only bases 2, 8, 10, 16
+ ; only bases 2, 8, 10, 16
($check-error (string->number "10" 3))
-; only strings
+ ; only strings
($check-error (string->number #inert))
($check-error (string->number #inert 2))
($check-error (string->number 2))
($check-error (string->number 2 8))
-; only base 10 with inexact numbers
+ ; only base 10 with inexact numbers
($check-error (string->number "-1.0" 2))
($check-error (string->number "1.25" 8))
($check-error (string->number "3.0" 16))
diff --git a/src/tests/pair-mutation.k b/src/tests/pair-mutation.k
@@ -17,8 +17,8 @@
;; copy-es-immutable
($let* ((orig (list (cons 1 2) (cons 3 4)))
- (copy (copy-es-immutable orig))
- (copy2 (copy-es-immutable copy)))
+ (copy (copy-es-immutable orig))
+ (copy2 (copy-es-immutable copy)))
($check equal? orig copy)
($check-predicate (mutable-pair? orig))
($check-predicate (immutable-pair? copy))
@@ -27,33 +27,33 @@
;; encycle!
($check equal? ($let ((l 1)) (encycle! l 0 0) l)
- 1)
+ 1)
($check equal? ($let ((l (list 1 2 3 4 5))) (encycle! l 4 0) l)
- (list 1 2 3 4 5))
+ (list 1 2 3 4 5))
($check equal? ($let ((l (list 1 2 3 4 5))) (encycle! l 2 3) l)
- (list 1 2 . #0=(3 4 5 . #0#)))
+ (list 1 2 . #0=(3 4 5 . #0#)))
($check equal? ($let ((l (list* 1 2 3 4 5))) (encycle! l 0 3) l)
- (list . #0=(1 2 3 . #0#)))
+ (list . #0=(1 2 3 . #0#)))
;; list-set!
($check-predicate (inert? (list-set! (list 0 1 2 3) 0 10)))
($check equal? ($let ((l (list 0 1 2 3)))
- (list-set! l 1 10)
- (list-set! l 3 30)
- l)
- (list 0 10 2 30))
+ (list-set! l 1 10)
+ (list-set! l 3 30)
+ l)
+ (list 0 10 2 30))
($check equal? ($let ((l (list 0 . #1=(1 2 . #1#))))
- (list-set! l 1 10)
- (list-set! l 4 20)
- l)
- (list 0 . #2=(10 20 . #2#)))
+ (list-set! l 1 10)
+ (list-set! l 4 20)
+ l)
+ (list 0 . #2=(10 20 . #2#)))
;; see kgpair_mut.c for rationale on allowing
;; improper lists as argument to list-set!
($check equal? ($let ((l (list* 0 1 2 3)))
- (list-set! l 1 10)
- (list-set! l 2 20)
- l)
- (list* 0 10 20 3))
+ (list-set! l 1 10)
+ (list-set! l 2 20)
+ l)
+ (list* 0 10 20 3))
;; append!
($check-predicate (inert? (append! (list 1) (list 2))))
@@ -81,28 +81,28 @@
($define! l3 (list 5 6))
($check equal?
- ($sequence (append! l1 . #3=(l2 l3 . #3#)) l1)
- (list 1 2 . #4=(3 4 5 6 . #4#)))
+ ($sequence (append! l1 . #3=(l2 l3 . #3#)) l1)
+ (list 1 2 . #4=(3 4 5 6 . #4#)))
($define! l1 (list 1 2))
($define! l2 (list 3 4))
($define! l3 (list 5 6))
($check equal?
- ($sequence (append! l1 l2 l3 . #5=(() () . #5#)) l1)
- (list 1 2 3 4 5 6))
+ ($sequence (append! l1 l2 l3 . #5=(() () . #5#)) l1)
+ (list 1 2 3 4 5 6))
($define! l1 (list 1 2))
($define! l2 (list 3 4))
($define! l3 (list 5 6))
($check equal?
- ($sequence (append! l1 () . #6=(() l2 () l3 () . #6#)) l1)
- (list 1 2 . #7=(3 4 5 6 . #7#))))
+ ($sequence (append! l1 () . #6=(() l2 () l3 () . #6#)) l1)
+ (list 1 2 . #7=(3 4 5 6 . #7#))))
;; copy-es
($let* ((orig (list (cons 1 2) (cons 3 4)))
- (copy (copy-es orig)))
+ (copy (copy-es orig)))
($check equal? orig copy)
($check-predicate (mutable-pair? orig))
($check-predicate (mutable-pair? copy))
@@ -113,14 +113,14 @@
($check equal? (assq 3 (list (list 1 10) (list 2 20))) ())
($check equal? (assq 1 (list (list 1 10) (list 2 20))) (list 1 10))
($check equal?
- (assq 1 (list . #0=((list 1 10) (list 2 20) (list 1 15) . #0#)))
- (list 1 10))
+ (assq 1 (list . #0=((list 1 10) (list 2 20) (list 1 15) . #0#)))
+ (list 1 10))
($check equal?
- (assq 4 (list . #0=((list 1 10) (list 2 20) (list 1 15) . #0#)))
- ())
+ (assq 4 (list . #0=((list 1 10) (list 2 20) (list 1 15) . #0#)))
+ ())
($check equal?
- (assq (list 1) (list (list (list 1) 1) (list (list 2) 2)))
- ())
+ (assq (list 1) (list (list (list 1) 1) (list (list 2) 2)))
+ ())
;; memq
($check-predicate (memq? 1 (list 1 2)))
@@ -132,7 +132,7 @@
($check-predicate
(memq? 3 (list . #0=(1 2 3 . #0#))))
($check-not-predicate
- (memq? 4 (list . #0=(1 2 1 . #0#))))
+ (memq? 4 (list . #0=(1 2 1 . #0#))))
;;;
@@ -205,12 +205,12 @@
($check-error (append! (list 1 2) 3 ()))
($check-error (append! ((unwrap list) . (1 2 . #0=(3)))
- ((unwrap list) . (4 5 . #0#))
- ()))
+ ((unwrap list) . (4 5 . #0#))
+ ()))
;; ASK if this is valid or not
;; ($check-error (append! ((unwrap list) . (1 2 . #0=(3)))
-;; ((unwrap list) . (4 5 . #0#))))
+;; ((unwrap list) . (4 5 . #0#))))
;; copy-es
diff --git a/src/tests/pairs-and-lists.k b/src/tests/pairs-and-lists.k
@@ -14,8 +14,10 @@
($check-predicate (pair?))
($check-predicate (pair? (cons () ())))
-($check-predicate (pair? (cons () ()) (copy-es-immutable (cons () ())) (cons () ())))
-($check-predicate (pair? (cons () ()) . #0=((copy-es-immutable (cons () ())) . #0#)))
+($check-predicate (pair? (cons () ())
+ (copy-es-immutable (cons () ())) (cons () ())))
+($check-predicate (pair? (cons () ()) .
+ #0=((copy-es-immutable (cons () ())) . #0#)))
($check-not-predicate (null? #t))
($check-not-predicate (null? ((unwrap list) . symbol)))
@@ -27,8 +29,8 @@
($check-not-predicate (null? wrap))
($check-not-predicate (null? (call/cc ($lambda (c) c))))
($check-not-predicate (null? ($let (((enc . #ignore)
- (make-encapsulation-type)))
- (enc #inert))))
+ (make-encapsulation-type)))
+ (enc #inert))))
($check-not-predicate (null? (memoize #inert)))
($check-not-predicate (null? 1))
($check-not-predicate (null? 1.0))
@@ -50,8 +52,8 @@
($check-not-predicate (pair? wrap))
($check-not-predicate (pair? (call/cc ($lambda (c) c))))
($check-not-predicate (pair? ($let (((enc . #ignore)
- (make-encapsulation-type)))
- (enc #inert))))
+ (make-encapsulation-type)))
+ (enc #inert))))
($check-not-predicate (pair? (memoize #inert)))
($check-not-predicate (pair? 1))
($check-not-predicate (pair? 1.0))
@@ -90,10 +92,10 @@
($check equal? (cdr (cons 1 2)) 2)
($let* ((tree2 (cons 1 2))
- (tree4 (cons tree2 (cons 3 4)))
- (tree8 (cons tree4 (cons (cons 5 6) (cons 7 8))))
- (tree16 (cons tree8 (cons (cons (cons 9 10) (cons 11 12))
- (cons (cons 13 14) (cons 15 16))))))
+ (tree4 (cons tree2 (cons 3 4)))
+ (tree8 (cons tree4 (cons (cons 5 6) (cons 7 8))))
+ (tree16 (cons tree8 (cons (cons (cons 9 10) (cons 11 12))
+ (cons (cons 13 14) (cons 15 16))))))
($check eq? (car tree2) 1)
($check eq? (cdr tree2) 2)
@@ -190,28 +192,28 @@
($let ((l1 (list 1 2)) (l2 (list 3 4))) ; here the last list is copied
($check not-eq? (cddr (append l1 l2 ())) l2))
($check equal?
- (append (list 1 2) (list 3 4) . #0=((list 5 6) . #0#))
- (list 1 2 3 4 . #1=(5 6 . #1#)))
+ (append (list 1 2) (list 3 4) . #0=((list 5 6) . #0#))
+ (list 1 2 3 4 . #1=(5 6 . #1#)))
($check equal?
- (append () () . #0=(() (list 1 2) () . #0#))
- (list . #1=(1 2 . #1#)))
+ (append () () . #0=(() (list 1 2) () . #0#))
+ (list . #1=(1 2 . #1#)))
($check equal?
- (append (list 1 2) (list 3 4) . #0=(() () . #0#))
- (list 1 2 3 4))
+ (append (list 1 2) (list 3 4) . #0=(() () . #0#))
+ (list 1 2 3 4))
;; list-neighbors
($check equal? (list-neighbors ()) ())
($check equal? (list-neighbors (list 1)) ())
($check equal? (list-neighbors (list 1 2)) (list (list 1 2)))
($check equal?
- (list-neighbors (list 1 2 3 4))
- (list (list 1 2) (list 2 3) (list 3 4)))
+ (list-neighbors (list 1 2 3 4))
+ (list (list 1 2) (list 2 3) (list 3 4)))
($check equal?
- (list-neighbors (list . #0=(1 2 3 4 . #0#)))
- (list . #1=((list 1 2) (list 2 3) (list 3 4) (list 4 1) . #1#)))
+ (list-neighbors (list . #0=(1 2 3 4 . #0#)))
+ (list . #1=((list 1 2) (list 2 3) (list 3 4) (list 4 1) . #1#)))
($check equal?
- (list-neighbors (list 1 2 . #0=(3 4 . #0#)))
- (list (list 1 2) (list 2 3) . #1=((list 3 4) (list 4 3) . #1#)))
+ (list-neighbors (list 1 2 . #0=(3 4 . #0#)))
+ (list (list 1 2) (list 2 3) . #1=((list 3 4) (list 4 3) . #1#)))
;; filter
($check equal? (filter number? ()) ())
@@ -219,19 +221,19 @@
($check equal? (filter number? (list 1 2 3)) (list 1 2 3))
($check equal? (filter number? (list 1 #t 2 #f)) (list 1 2))
($check equal?
- (filter number? (list 1 #t . #0=(2 #f . #0#)))
- (list 1 . #1=(2 . #1#)))
+ (filter number? (list 1 #t . #0=(2 #f . #0#)))
+ (list 1 . #1=(2 . #1#)))
($check equal?
- (filter number? (list #t 1 #f . #0=(#t #f . #0#)))
- (list 1))
+ (filter number? (list #t 1 #f . #0=(#t #f . #0#)))
+ (list 1))
($check equal?
- (filter number? (list #t #f . #0=(#t #f . #0#)))
- ())
+ (filter number? (list #t #f . #0=(#t #f . #0#)))
+ ())
($check equal? ; filter should use an empty environment
- (filter (wrap ($vau #ignore denv ($binds? denv $if)))
- (list 1 2 3))
- ())
+ (filter (wrap ($vau #ignore denv ($binds? denv $if)))
+ (list 1 2 3))
+ ())
;; assoc
($check equal? (assoc #inert ()) ())
@@ -239,19 +241,19 @@
($check equal? (assoc 1 (list (list 1 10) (list 2 20))) (list 1 10))
($check equal? (assoc 1 (list (list 1 10) (list 2 20)) =?) (list 1 10))
($check equal?
- (assoc 1 (list . #0=((list 1 10) (list 2 20) (list 1 15) . #0#)))
- (list 1 10))
+ (assoc 1 (list . #0=((list 1 10) (list 2 20) (list 1 15) . #0#)))
+ (list 1 10))
($check equal?
- (assoc 4 (list . #0=((list 1 10) (list 2 20) (list 1 15) . #0#)))
- ())
+ (assoc 4 (list . #0=((list 1 10) (list 2 20) (list 1 15) . #0#)))
+ ())
($check equal?
- (assoc (list 1) (list (list (list 1) 1) (list (list 2) 2)))
- (list (list 1) 1))
+ (assoc (list 1) (list (list (list 1) 1) (list (list 2) 2)))
+ (list (list 1) 1))
($check equal?
- (assoc 4 (list . #0=((list 1 10) (list 2 20) (list 1 15) . #0#))
- =?)
- ())
+ (assoc 4 (list . #0=((list 1 10) (list 2 20) (list 1 15) . #0#))
+ =?)
+ ())
;; member?
($check-predicate (member? 1 (list 1 2)))
($check-predicate (member? 2 (list 1 2)))
@@ -260,13 +262,13 @@
($check-predicate (member? (list 1) (list (list 1) 2)))
($check-predicate (member? (list 2) (list 1 (list 2))))
($check-predicate
- (member? (list 1 3) (list . #0=(1 2 (list 1 3) . #0#))))
+ (member? (list 1 3) (list . #0=(1 2 (list 1 3) . #0#))))
($check-not-predicate
- (member? 4 (list . #0=(1 2 1 . #0#))))
+ (member? 4 (list . #0=(1 2 1 . #0#))))
($check-predicate (member? -1 (list 1 2) ($lambda (x y) (=? x (- 0 y)))))
($check-not-predicate (member? 1 (list 1 2 . #0=(3 4 . #0#))
- ($lambda (x y) (=? x (- 0 y)))))
+ ($lambda (x y) (=? x (- 0 y)))))
;; finite-list?
($check-predicate (finite-list? ()))
@@ -285,33 +287,33 @@
($check-predicate (countable-list? (list 1 . #0=(2 . #0#))))
($check-predicate (countable-list? (list 1 2) (list 1 . #0=(2 . #0#)) ()))
($check-predicate (countable-list?
- () . #0=((list 1 . #1=(2 . #1#)) () . #0#)))
+ () . #0=((list 1 . #1=(2 . #1#)) () . #0#)))
($check-not-predicate (countable-list? 1))
($check-not-predicate (countable-list? () 1))
($check-not-predicate (countable-list? (list 1 2) . #0=(#inert () . #0#)))
($check-not-predicate (countable-list?
- () . #0=((list 1 . #1=(2 . #1#)) 3 . #0#)))
+ () . #0=((list 1 . #1=(2 . #1#)) 3 . #0#)))
;; reduce
($let ((ac-+ ($lambda ls (reduce ls + 0)))
(c-+
-;; the idea of the cycle treatment is to carry a flag indicating
-;; if all elements so far in the cycle were actually zero, if so
-;; the sum of the cycle is zero otherwise it can be undefined or
-;; (* +infinity (acyclic-sum)) which in the integer case is +infinity
-;; or -infinity
- ($let ((precycle ($lambda (x)
- (cons x (zero? x))))
- (incycle ($lambda ((x . x-zero?) (y . y-zero?))
- (cons (+ x y)
- (and? x-zero? y-zero?))))
- (postcycle ($lambda ((result . all-zero?))
- ($if all-zero?
- 0
- (* #e+infinity result)))))
- ($lambda ls
- (reduce ls + 0 precycle incycle postcycle)))))
+ ;; the idea of the cycle treatment is to carry a flag indicating
+ ;; if all elements so far in the cycle were actually zero, if so
+ ;; the sum of the cycle is zero otherwise it can be undefined or
+ ;; (* +infinity (acyclic-sum)) which in the integer case is +infinity
+ ;; or -infinity
+ ($let ((precycle ($lambda (x)
+ (cons x (zero? x))))
+ (incycle ($lambda ((x . x-zero?) (y . y-zero?))
+ (cons (+ x y)
+ (and? x-zero? y-zero?))))
+ (postcycle ($lambda ((result . all-zero?))
+ ($if all-zero?
+ 0
+ (* #e+infinity result)))))
+ ($lambda ls
+ (reduce ls + 0 precycle incycle postcycle)))))
($check equal? (ac-+) 0)
($check equal? (ac-+ 1) 1)
($check equal? (ac-+ 1 2) 3)
@@ -349,8 +351,8 @@
($check-error (cdr (cons 1 2) (cons 3 4)))
($let* ((tree2 (cons 1 2))
- (tree4 (cons tree2 (cons 3 4)))
- (tree8 (cons tree4 (cons (cons 5 6) (cons 7 8)))))
+ (tree4 (cons tree2 (cons 3 4)))
+ (tree8 (cons tree4 (cons (cons 5 6) (cons 7 8)))))
($check-error (caar tree2))
($check-error (cdar tree2))
($check-error (cadr tree2))
@@ -413,7 +415,7 @@
($check-error (list-tail (list 1 2 3) 3 4))
($check-error (list-tail (list 1 2 3) 4))
($check-error (list-tail (list 1 2 3) #e+infinity))
-;($check-error (list-tail (list 1 2 3) 3.4))
+ ;($check-error (list-tail (list 1 2 3) 3.4))
($check-error (list-tail (list 1 2 3) -1))
($check-error (list-tail (list 1 2 3) #f))
@@ -428,7 +430,7 @@
($check-error (list-ref (list 1 2 3) 3 4))
($check-error (list-ref (list 1 2 3) 4))
($check-error (list-ref (list 1 2 3) #e+infinity))
-;($check-error (list-ref (list 1 2 3) 3.4))
+ ;($check-error (list-ref (list 1 2 3) 3.4))
($check-error (list-ref (list 1 2 3) -1))
($check-error (list-ref (list 1 2 3) #f))
@@ -468,7 +470,7 @@
($check-error (assoc 4 (list (list 1 1) (list 2 2) #inert (list 4 4))))
($check-error (assoc 2 (list (list 1 1) (list 2 2) #inert (list 4 4))))
($check-error (assoc 2 (list (list 1 1) (list 2 2) #inert (list 4 4))
- equal?))
+ equal?))
;; member?
($check-error (member?))
diff --git a/src/tests/ports.k b/src/tests/ports.k
@@ -33,21 +33,21 @@
($define! prepare-input
($lambda (text)
(with-output-to-file temp-file
- ($lambda () ($if (string? text)
- (display text)
- #inert)))))
+ ($lambda () ($if (string? text)
+ (display text)
+ #inert)))))
($define! read-string-until-eof
($lambda ()
($letrec
- ( (loop ($lambda (prefix)
- ($let ((c (read-char)))
- ($if (eof-object? c)
- #inert
- ($sequence
- (set-cdr! prefix (cons c ()))
- (loop (cdr prefix)))))))
- (buf (cons () ())))
+ ( (loop ($lambda (prefix)
+ ($let ((c (read-char)))
+ ($if (eof-object? c)
+ #inert
+ ($sequence
+ (set-cdr! prefix (cons c ()))
+ (loop (cdr prefix)))))))
+ (buf (cons () ())))
(loop buf)
(list->string (cdr buf)))))
@@ -118,16 +118,16 @@
($check-error (with-output-to-file invalid-file ($lambda () 1)))
($check equal?
- ($let ((orig (get-current-input-port)))
- (with-input-from-file test-input-file
- ($lambda () (equal? orig (get-current-input-port)))))
- #f)
+ ($let ((orig (get-current-input-port)))
+ (with-input-from-file test-input-file
+ ($lambda () (equal? orig (get-current-input-port)))))
+ #f)
($check equal?
- ($let ((orig (get-current-output-port)))
- (with-output-to-file temp-file
- ($lambda () (equal? orig (get-current-output-port)))))
- #f)
+ ($let ((orig (get-current-output-port)))
+ (with-output-to-file temp-file
+ ($lambda () (equal? orig (get-current-output-port)))))
+ #f)
;; 15.1.4 get-current-input-port? get-current-output-port?
;; Functionality covered by other tests
@@ -177,30 +177,30 @@
($check equal? ($output-test #inert) "")
($check equal?
- ($output-test (write (list 123 12345678901234567890 1/2 -3.14)))
- "(123 12345678901234567890 1/2 -3.14)")
+ ($output-test (write (list 123 12345678901234567890 1/2 -3.14)))
+ "(123 12345678901234567890 1/2 -3.14)")
($check equal?
- ($output-test (write (list #e+infinity #e-infinity #i+infinity #i-infinity #real #undefined)))
- "(#e+infinity #e-infinity #i+infinity #i-infinity #real #undefined)")
+ ($output-test (write (list #e+infinity #e-infinity #i+infinity #i-infinity #real #undefined)))
+ "(#e+infinity #e-infinity #i+infinity #i-infinity #real #undefined)")
($check equal?
- ($output-test (write (list #\x #\newline #\space)))
- "(#\\x #\\newline #\\space)")
+ ($output-test (write (list #\x #\newline #\space)))
+ "(#\\x #\\newline #\\space)")
($check equal?
- ($output-test (write (list #t #f)))
- "(#t #f)")
+ ($output-test (write (list #t #f)))
+ "(#t #f)")
($check equal?
- ($output-test (write (list #inert #ignore)))
- "(#inert #ignore)")
+ ($output-test (write (list #inert #ignore)))
+ "(#inert #ignore)")
($check equal? ($output-test (write "")) "\"\"")
($check equal? ($output-test (write "a\\b\"")) "\"a\\\\b\\\"\"")
($check equal?
- ($output-test (write (list 1 2 (list 3 4 5) () (list* 6 7))))
- "(1 2 (3 4 5) () (6 . 7))")
+ ($output-test (write (list 1 2 (list 3 4 5) () (list* 6 7))))
+ "(1 2 (3 4 5) () (6 . 7))")
($check equal?
- ($output-test (write ($quote #0=(1 2 #1=(3 4 . #0#) #2="abc" #3=(5 6 #1# #2# #3# . #0#)))))
- "#0=(1 2 #1=(3 4 . #0#) #2=\"abc\" #3=(5 6 #1# #2# #3# . #0#))")
+ ($output-test (write ($quote #0=(1 2 #1=(3 4 . #0#) #2="abc" #3=(5 6 #1# #2# #3# . #0#)))))
+ "#0=(1 2 #1=(3 4 . #0#) #2=\"abc\" #3=(5 6 #1# #2# #3# . #0#))")
($check-error (write 0 (get-current-input-port)))
($check-error (call-with-closed-output-port ($lambda (p) (write 0 p))))
@@ -215,7 +215,7 @@
;; Additional input functions: eof-object? read-char peek-char
($check-predicate ($false-for-all? eof-object?
- 0 -1 #t #f () "" (get-current-input-port)))
+ 0 -1 #t #f () "" (get-current-input-port)))
($check-predicate (eof-object? ($input-test "" (read-char))))
($check-predicate (eof-object? ($input-test "" (peek-char))))
@@ -269,27 +269,27 @@
;;
;; ($define! colliding-output-test
;; ($lambda (combiner)
-;; (call-with-output-file temp-file
-;; ($lambda (p1)
-;; (call-with-output-file temp-file
-;; ($lambda (p2)
-;; (combiner p1 p2)))))
-;; (with-input-from-file temp-file read-string-until-eof)))
+;; (call-with-output-file temp-file
+;; ($lambda (p1)
+;; (call-with-output-file temp-file
+;; ($lambda (p2)
+;; (combiner p1 p2)))))
+;; (with-input-from-file temp-file read-string-until-eof)))
;;
;; ($check equal?
;; (colliding-output-test ($lambda (p1 p2)
-;; (display "1" p1)
-;; (display "2" p2)
-;; (flush-output-port p1)
-;; (flush-output-port p2)))
+;; (display "1" p1)
+;; (display "2" p2)
+;; (flush-output-port p1)
+;; (flush-output-port p2)))
;; "12")
;;
;; ($check equal?
;; (colliding-output-test ($lambda (p1 p2)
-;; (display "1" p1)
-;; (display "2" p2)
-;; (flush-output-port p2)
-;; (flush-output-port p1)))
+;; (display "1" p1)
+;; (display "2" p2)
+;; (flush-output-port p2)
+;; (flush-output-port p1)))
;; "21")
diff --git a/src/tests/promises.k b/src/tests/promises.k
@@ -26,7 +26,7 @@
($check-error ($lazy))
($check-error ($lazy "too" "many"))
($check equal? (force ($lazy (get-current-environment)))
- (get-current-environment))
+ (get-current-environment))
;; Test cases from R(-1)RK
($define! lazy-test-1
@@ -37,28 +37,28 @@
($define! p
($let ((self (get-current-environment)))
($lazy
- ($if (<=? count 0)
- count
- ($sequence
- ($set! self count (- count 1))
- (force p)
- ($set! self count (+ count 2))
- count))))))
+ ($if (<=? count 0)
+ count
+ ($sequence
+ ($set! self count (- count 1))
+ (force p)
+ ($set! self count (+ count 2))
+ count))))))
($check equal? (get-count) 5)
($check equal? (force p) 0)
($check equal? (get-count) 10)))
($define! lazy-test-2
($let
- ((temp-file "klisp-ports-test.txt"))
+ ((temp-file "klisp-ports-test.txt"))
(with-output-to-file temp-file
- ($lambda ()
- ($define! p1 ($lazy (display "*")))
- ($define! p2 ($lazy p1))
- (force p2)
- (force p1)))
+ ($lambda ()
+ ($define! p1 ($lazy (display "*")))
+ ($define! p2 ($lazy p1))
+ (force p2)
+ (force p1)))
($let
- ((result (with-input-from-file temp-file read)))
+ ((result (with-input-from-file temp-file read)))
(delete-file temp-file)
result)))
@@ -76,19 +76,19 @@
($define! stream-filter
($lambda (p? s)
($lazy
- ($let ((v (force s)))
- ($if (null? v)
- v
- ($let ((s (stream-filter p? (cdr v))))
- ($if (p? (car v))
- (cons (car v) s)
- s)))))))
+ ($let ((v (force s)))
+ ($if (null? v)
+ v
+ ($let ((s (stream-filter p? (cdr v))))
+ ($if (p? (car v))
+ (cons (car v) s)
+ s)))))))
($define! from
($lambda (n)
($lazy (cons n (from (+ n 1))))))
(force
- (stream-filter ($lambda (n) (=? n 100))
- (from 0)))))
+ (stream-filter ($lambda (n) (=? n 100))
+ (from 0)))))
($check equal? (car lazy-test-3) 100)
@@ -114,6 +114,6 @@
($check equal? (force ($delay 0)) 0)
($check equal? (force (force ($delay 0))) 0)
($check equal? (force ($delay (get-current-environment)))
- (get-current-environment))
+ (get-current-environment))
($check-predicate (promise? (force ($delay (memoize 0)))))
($check equal? (force (force ($delay (memoize 0)))) 0)
diff --git a/src/tests/strings.k b/src/tests/strings.k
@@ -39,13 +39,13 @@
($check-not-predicate (string<? "b" "a"))
($check-predicate ($true-for-all-combinations? string<=?
- ("" "A") ("a" "A" "ab")))
+ ("" "A") ("a" "A" "ab")))
($check-predicate ($true-for-all-combinations? string>?
- ("b" "c") ("" "a")))
+ ("b" "c") ("" "a")))
($check-predicate ($true-for-all-combinations? string>=?
- ("b" "c") ("" "a" "b")))
+ ("b" "c") ("" "a" "b")))
($check-predicate (string-ci=? "" ""))
($check-predicate (string-ci=? "abcd" "AbCd"))
@@ -53,18 +53,18 @@
($check-not-predicate (string=? "aa" "AAA"))
($check-predicate ($true-for-all-combinations? string-ci<?
- ("" "a" "A") ("ab" "AB" "b" "B")))
+ ("" "a" "A") ("ab" "AB" "b" "B")))
($check-predicate ($false-for-all-combinations? string-ci<?
- ("b" "B") ("" "a" "A" "aa" "b" "B" "ab" "aB" "Ab" "AB")))
+ ("b" "B") ("" "a" "A" "aa" "b" "B" "ab" "aB" "Ab" "AB")))
($check-predicate ($true-for-all-combinations? string-ci<=?
- ("" "A" "a") ("a" "A" "ab")))
+ ("" "A" "a") ("a" "A" "ab")))
($check-predicate ($true-for-all-combinations? string-ci>?
- ("b" "B" "c" "C") ("" "a" "A")))
+ ("b" "B" "c" "C") ("" "a" "A")))
($check-predicate ($true-for-all-combinations? string-ci>=?
- ("b" "B" "c" "C") ("" "a" "A" "b" "B")))
+ ("b" "B" "c" "C") ("" "a" "A" "b" "B")))
;; XXX make-string
@@ -88,13 +88,13 @@
;; XXX string-upcase string-downcase string-titlecase string-foldcase
($check equal? (string-upcase "ABCDEFGHIJKLMNOPQRSTUVWXYZ01234567890abcdefghijklmnopqrstuvwxyz")
- "ABCDEFGHIJKLMNOPQRSTUVWXYZ01234567890ABCDEFGHIJKLMNOPQRSTUVWXYZ")
+ "ABCDEFGHIJKLMNOPQRSTUVWXYZ01234567890ABCDEFGHIJKLMNOPQRSTUVWXYZ")
($check equal? (string-titlecase "this is a regular sentence. this 1 2!")
- "This Is A Regular Sentence. This 1 2!")
+ "This Is A Regular Sentence. This 1 2!")
($check equal? (string-downcase "ABCDEFGHIJKLMNOPQRSTUVWXYZ01234567890abcdefghijklmnopqrstuvwxyz")
- "abcdefghijklmnopqrstuvwxyz01234567890abcdefghijklmnopqrstuvwxyz")
+ "abcdefghijklmnopqrstuvwxyz01234567890abcdefghijklmnopqrstuvwxyz")
($check equal? (string-foldcase "ABCDEFGHIJKLMNOPQRSTUVWXYZ01234567890abcdefghijklmnopqrstuvwxyz")
- "abcdefghijklmnopqrstuvwxyz01234567890abcdefghijklmnopqrstuvwxyz")
+ "abcdefghijklmnopqrstuvwxyz01234567890abcdefghijklmnopqrstuvwxyz")
($check-predicate (mutable-string? (string-upcase (string-copy "A0a"))))
($check-predicate (mutable-string? (string-upcase "A0a")))
($check-predicate (mutable-string? (string-downcase (string-copy "A0a"))))
@@ -154,8 +154,8 @@
;; substring generates mutable strings
;; Andres Navarro
($check-predicate
- ($let* ((p "abc") (q (string->immutable-string (substring p 0 3))))
- (eq? p q)))
+ ($let* ((p "abc") (q (string->immutable-string (substring p 0 3))))
+ (eq? p q)))
;; string-copy always generate mutable strings
;; Andres Navarro
@@ -176,8 +176,8 @@
($check equal? (string-append "a" "b" "c") "abc")
($check-not-predicate
- ($let* ((p "abc") (q (string-append p)))
- (eq? p q)))
+ ($let* ((p "abc") (q (string-append p)))
+ (eq? p q)))
($check-predicate (nonempty-mutable-string? (string-append "a" "b")))
@@ -187,8 +187,8 @@
($check equal? (string-copy "abcd") "abcd")
($check-not-predicate
- ($let* ((p "abc") (q (string-copy p)))
- (eq? p q)))
+ ($let* ((p "abc") (q (string-copy p)))
+ (eq? p q)))
($check-predicate (nonempty-mutable-string? (string-copy "abc")))
@@ -198,8 +198,8 @@
($check equal? (string->immutable-string "abcd") "abcd")
($check-not-predicate
- ($let* ((p "abc") (q (string-copy p)))
- (eq? p q)))
+ ($let* ((p "abc") (q (string-copy p)))
+ (eq? p q)))
($check-predicate (immutable-string? (string->immutable-string "")))
($check-predicate (immutable-string? (string->immutable-string "abc")))
@@ -216,11 +216,11 @@
($check equal? (list->string (list #\a #\b #\c)) "abc")
($check-not-predicate
- ($let*
- ( (cs (list #\a #\b #\c))
- (x (list->string cs))
- (y (list->string cs)))
- (eq? x y)))
+ ($let*
+ ( (cs (list #\a #\b #\c))
+ (x (list->string cs))
+ (y (list->string cs)))
+ (eq? x y)))
($check-predicate (nonempty-mutable-string? (list->string (list #\a #\b))))
@@ -233,11 +233,11 @@
($check-not-predicate (equal? (string->vector "abc") (vector #\a #\B #\c)))
($check-not-predicate
- ($let*
- ( (str "abc")
- (x (string->vector str))
- (y (string->vector str)))
- (eq? x y)))
+ ($let*
+ ( (str "abc")
+ (x (string->vector str))
+ (y (string->vector str)))
+ (eq? x y)))
($check-predicate (mutable-vector? (string->vector "abc")))
@@ -247,11 +247,11 @@
($check equal? (vector->string (vector #\a #\b #\c)) "abc")
($check-not-predicate
- ($let*
- ( (cs (vector #\a #\b #\c))
- (x (vector->string cs))
- (y (vector->string cs)))
- (eq? x y)))
+ ($let*
+ ( (cs (vector #\a #\b #\c))
+ (x (vector->string cs))
+ (y (vector->string cs)))
+ (eq? x y)))
($check-predicate (mutable-string? (vector->string (vector #\a #\b))))
@@ -263,16 +263,16 @@
($check equal? (string->bytevector "") (bytevector))
($check equal? (string->bytevector "aBc")
- (bytevector (char->integer #\a)
- (char->integer #\B)
- (char->integer #\c)))
+ (bytevector (char->integer #\a)
+ (char->integer #\B)
+ (char->integer #\c)))
($check-not-predicate
- ($let*
- ( (str "abc")
- (x (string->bytevector str))
- (y (string->bytevector str)))
- (eq? x y)))
+ ($let*
+ ( (str "abc")
+ (x (string->bytevector str))
+ (y (string->bytevector str)))
+ (eq? x y)))
($check-predicate (mutable-bytevector? (string->bytevector "abc")))
@@ -280,22 +280,22 @@
($check equal? (bytevector->string (bytevector)) "")
($check equal? (bytevector->string (bytevector (char->integer #\a)
- (char->integer #\b)
- (char->integer #\c)))
- "abc")
+ (char->integer #\b)
+ (char->integer #\c)))
+ "abc")
($check-not-predicate
- ($let*
- ((cs (bytevector (char->integer #\a)
- (char->integer #\b)
- (char->integer #\c)))
+ ($let*
+ ((cs (bytevector (char->integer #\a)
+ (char->integer #\b)
+ (char->integer #\c)))
(x (bytevector->string cs))
(y (bytevector->string cs)))
- (eq? x y)))
+ (eq? x y)))
($check-predicate (mutable-string?
- (bytevector->string (bytevector (char->integer #\a)
- (char->integer #\b)))))
+ (bytevector->string (bytevector (char->integer #\a)
+ (char->integer #\b)))))
;; errors
($check-error (bytevector->string (bytevector 128))) ;; only ASCII
@@ -314,5 +314,5 @@
($check equal? (symbol->string ($quote abcd)) "abcd")
($check equal?
- ($quote sym)
- (string->symbol (symbol->string ($quote sym))))
+ ($quote sym)
+ (string->symbol (symbol->string ($quote sym))))
diff --git a/src/tests/symbols.k b/src/tests/symbols.k
@@ -9,8 +9,8 @@
($let (($qs ($vau (s) #ignore s)))
($let ((s1 ($qs s1))
- (s2 ($qs s2))
- (s3 ($qs s3)))
+ (s2 ($qs s2))
+ (s3 ($qs s3)))
($check-predicate (symbol?))
($check-predicate (symbol? s1))
($check-predicate (symbol? s1 s2 s3))
@@ -24,8 +24,8 @@
($check-not-predicate (symbol? wrap))
($check-not-predicate (symbol? (call/cc ($lambda (c) c))))
($check-not-predicate (symbol? ($let (((enc . #ignore)
- (make-encapsulation-type)))
- (enc #inert))))
+ (make-encapsulation-type)))
+ (enc #inert))))
($check-not-predicate (symbol? (memoize #inert)))
($check-not-predicate (symbol? 1))
($check-not-predicate (symbol? 1.0))
diff --git a/src/tests/system.k b/src/tests/system.k
@@ -21,7 +21,7 @@
($check-predicate (positive? (current-jiffy) (jiffies-per-second)))
($let* ((jiffy1 (current-jiffy)) (jiffy2 (current-jiffy)))
- ($check-predicate (<=? jiffy1 jiffy2)))
+ ($check-predicate (<=? jiffy1 jiffy2)))
($let* ((jps1 (jiffies-per-second)) (jps2 (jiffies-per-second)))
- ($check-predicate (=? jps1 jps2)))
+ ($check-predicate (=? jps1 jps2)))
diff --git a/src/tests/test-helpers.k b/src/tests/test-helpers.k
@@ -8,11 +8,11 @@
($define! $check-predicate ($vau (x) denv (eval (list $check eq? x #t) denv)))
($define! $check-not-predicate ($vau (x) denv (eval (list $check eq? x #f) denv)))
($define! $check-no-error ($vau (x) denv
- (eval (list $check
- ($lambda (#ignore #ignore) #t)
- x
- #inert)
- denv)))
+ (eval (list $check
+ ($lambda (#ignore #ignore) #t)
+ x
+ #inert)
+ denv)))
;; mutable-pair?, immutable-pair?, mutable-string? & immutable-string?
;; were added to the ground environment
@@ -20,17 +20,17 @@
($define! mutable-pair?
($lambda (obj)
($and? (pair? obj)
- (guard-dynamic-extent
- ()
- ($lambda ()
- (set-car! obj (car obj))
- #t)
- ;; As per the report (section 4.7.1) setting the car of an
- ;; immutable pair (even if the value is the same) should
- ;; signal an error.
- (list (list error-continuation
- ($lambda (#ignore divert)
- (apply divert #f))))))))
+ (guard-dynamic-extent
+ ()
+ ($lambda ()
+ (set-car! obj (car obj))
+ #t)
+ ;; As per the report (section 4.7.1) setting the car of an
+ ;; immutable pair (even if the value is the same) should
+ ;; signal an error.
+ (list (list error-continuation
+ ($lambda (#ignore divert)
+ (apply divert #f))))))))
($define! immutable-pair?
($lambda (obj) ($and? (pair? obj) (not? (mutable-pair? obj)))))
@@ -38,14 +38,14 @@
($define! nonempty-mutable-string?
($lambda (obj)
($and?
- (string? obj)
- (>? (string-length obj) 0)
- (guard-dynamic-extent
- ()
- ($lambda () (string-fill! obj #\x) #t)
- (list
- (list error-continuation
- ($lambda (#ignore divert) (apply divert #f))))))))
+ (string? obj)
+ (>? (string-length obj) 0)
+ (guard-dynamic-extent
+ ()
+ ($lambda () (string-fill! obj #\x) #t)
+ (list
+ (list error-continuation
+ ($lambda (#ignore divert) (apply divert #f))))))))
($define! immutable-string?
($lambda (obj) ($and? (string? obj) (not? (nonempty-mutable-string? obj)))))
@@ -66,7 +66,7 @@
($define! $false-for-all?
($vau (p . xs) denv
(apply and?
- (map ($lambda (x) (not? (eval (list p x) denv))) xs))))
+ (map ($lambda (x) (not? (eval (list p x) denv))) xs))))
;; (cartesian-product XS YS) returns list of all pairs (X Y),
;; where X is a member of the list XS and Y is a member of list YS.
@@ -77,7 +77,7 @@
($define! cartesian-product
($lambda (xs ys)
(apply append
- (map ($lambda (x) (map ($lambda (y) (list x y)) ys)) xs))))
+ (map ($lambda (x) (map ($lambda (y) (list x y)) ys)) xs))))
;; ($true-for-all-combinations? BIN (X1 X2...) (Y1 Y1...))
;; evaluates to #t, iff (BIN X Y) evaluates to #t for all X and Y.
@@ -85,8 +85,8 @@
($define! $true-for-all-combinations?
($vau (p xs ys) denv
(apply and?
- (map ($lambda ((x y)) (eval (list p x y) denv))
- (cartesian-product xs ys)))))
+ (map ($lambda ((x y)) (eval (list p x y) denv))
+ (cartesian-product xs ys)))))
;; ($false-for-all-combinations? BIN (X1 X2...) (Y1 Y2...))
;; evaluates to #t, iff (BIN X Y) evaluates to #f for all X and Y.
@@ -94,8 +94,8 @@
($define! $false-for-all-combinations?
($vau (p xs ys) denv
(apply and?
- (map ($lambda ((x y)) (not? (eval (list p x y) denv)))
- (cartesian-product xs ys)))))
+ (map ($lambda ((x y)) (not? (eval (list p x y) denv)))
+ (cartesian-product xs ys)))))
;; ($quote V) evaluates to V. The value V itself is not evaluated.
;; See section 5.5.1, page 67 of the Kernel Report.
diff --git a/src/tests/vectors.k b/src/tests/vectors.k
@@ -63,8 +63,8 @@
($check-predicate (applicative? vector-set!))
($let*
- ((v (make-vector 10))
- (w (vector->immutable-vector v)))
+ ((v (make-vector 10))
+ (w (vector->immutable-vector v)))
($check equal? (vector-set! v 0 1) #inert)
($check equal? (vector-ref v 0) 1)
($check equal? (vector-set! v 0 "abc") #inert)
@@ -88,12 +88,12 @@
;; (R7RS 3rd draft, section 6.3.6) vector-copy
($check equal? (vector-copy (vector 1 2 3)) (vector 1 2 3))
($check equal? (vector-copy (vector (vector 1 2 3) (vector 4 5 6)))
- (vector (vector 1 2 3) (vector 4 5 6)))
+ (vector (vector 1 2 3) (vector 4 5 6)))
($check-predicate (mutable-vector? (vector-copy (vector 1 2 3))))
($check-predicate
- (mutable-vector?
- (vector-copy (vector->immutable-vector (vector 1 2 3)))))
+ (mutable-vector?
+ (vector-copy (vector->immutable-vector (vector 1 2 3)))))
;; XXX bytevector->vector
@@ -101,11 +101,11 @@
($check equal? (bytevector->vector (u8 0 1 2)) (vector 0 1 2))
($check-not-predicate
- ($let*
- ((bb (u8 0 1 2))
- (x (bytevector->vector bb))
- (y (bytevector->vector bb)))
- (eq? x y)))
+ ($let*
+ ((bb (u8 0 1 2))
+ (x (bytevector->vector bb))
+ (y (bytevector->vector bb)))
+ (eq? x y)))
($check-predicate (mutable-vector? (bytevector->vector (u8 0 1 2))))
@@ -115,11 +115,11 @@
($check equal? (vector->bytevector (vector 0 1 2)) (u8 0 1 2))
($check-not-predicate
- ($let*
- ((cs (vector 0 1 2))
- (x (vector->bytevector cs))
- (y (vector->bytevector cs)))
- (eq? x y)))
+ ($let*
+ ((cs (vector 0 1 2))
+ (x (vector->bytevector cs))
+ (y (vector->bytevector cs)))
+ (eq? x y)))
($check-predicate (mutable-bytevector? (vector->bytevector (vector 0 1))))
@@ -140,9 +140,9 @@
($check equal? v (vector 9 9 3 4 5))
($check-error (vector-copy! (vector 1 2 3 4 5 6) v))
($check-error
- (vector-copy!
- (vector 1)
- (vector->immutable-vector (vector 1)))))
+ (vector-copy!
+ (vector 1)
+ (vector->immutable-vector (vector 1)))))
;; (R7RS 3rd draft, ) vector-copy-partial
@@ -158,8 +158,8 @@
;; additional property: destination must be mutable
;;
($let*
- ((v (make-vector 5 9))
- (w (vector->immutable-vector v)))
+ ((v (make-vector 5 9))
+ (w (vector->immutable-vector v)))
($check equal? (vector-copy-partial! (vector 1 2) 0 2 v 0) #inert)
($check equal? v (vector 1 2 9 9 9))
($check equal? (vector-copy-partial! (vector 5 6) 1 2 v 4) #inert)
@@ -174,15 +174,15 @@
;; XXX vector-fill!
($check-predicate (inert? (vector-fill! (vector 1 2) 0)))
($check equal? ($let ((v (vector 1 2 3)))
- (vector-fill! v "str")
- v)
- (vector "str" "str" "str"))
+ (vector-fill! v "str")
+ v)
+ (vector "str" "str" "str"))
;; XXX vector->immutable-vector
($check-predicate (applicative? vector->immutable-vector))
($check-predicate
- (immutable-vector? (vector->immutable-vector (vector 1 2))))
+ (immutable-vector? (vector->immutable-vector (vector 1 2))))
($check-not-predicate
- (mutable-vector? (vector->immutable-vector (vector 1 2))))
+ (mutable-vector? (vector->immutable-vector (vector 1 2))))
