commit ba1312b6edf6c8dec837d53a93e1cd1ecb5e15ce
parent a0c317c6f107ed640250c9683c004e7053effb77
Author: Andres Navarro <canavarro82@gmail.com>
Date: Fri, 21 Oct 2011 13:31:16 -0300
Merged back changes in default, before continuing work in r7rs features
Diffstat:
23 files changed, 1000 insertions(+), 70 deletions(-)
diff --git a/src/Makefile b/src/Makefile
@@ -27,7 +27,7 @@ PLATS= generic mingw posix
KRN_A= libklisp.a
CORE_O= kobject.o ktoken.o kpair.o kstring.o ksymbol.o kread.o \
kwrite.o kstate.o kmem.o kerror.o kauxlib.o kenvironment.o \
- kcontinuation.o koperative.o kapplicative.o keval.o krepl.o \
+ kcontinuation.o koperative.o kapplicative.o keval.o krepl.o kscript.o \
kencapsulation.o kpromise.o kport.o kinteger.o krational.o \
kreal.o ktable.o kgc.o imath.o imrat.o kblob.o \
kground.o kghelpers.o kgbooleans.o kgeqp.o kgequalp.o \
@@ -187,7 +187,7 @@ kgpairs_lists.o: kgpairs_lists.c kstate.h klimits.h klisp.h kobject.h \
kgports.o: kgports.c kstate.h klimits.h klisp.h kobject.h klispconf.h \
ktoken.h kmem.h kport.h kenvironment.h kapplicative.h koperative.h \
kcontinuation.h kpair.h kgc.h kerror.h ksymbol.h kstring.h kread.h \
- kwrite.h kghelpers.h kgports.h kgcontinuations.h kgcontrol.h kgkd_vars.h
+ kwrite.h kghelpers.h kgports.h kgcontinuations.h kgcontrol.h kgkd_vars.h kscript.h
kgpromises.o: kgpromises.c kstate.h klimits.h klisp.h kobject.h \
klispconf.h ktoken.h kmem.h kpromise.h kpair.h kgc.h kapplicative.h \
koperative.h kcontinuation.h kerror.h kghelpers.h kenvironment.h \
@@ -199,7 +199,7 @@ kground.o: kground.c kstate.h klimits.h klisp.h kobject.h klispconf.h \
kgequalp.h kgsymbols.h kgcontrol.h kgpairs_lists.h kgpair_mut.h \
kgenvironments.h kgenv_mut.h kgcombiners.h kgcontinuations.h \
kgencapsulations.h kgpromises.h kgkd_vars.h kgks_vars.h kgnumbers.h \
- kgstrings.h kgchars.h kgports.h kgblobs.h ktable.h keval.h krepl.h kgsystem.h
+ kgstrings.h kgchars.h kgports.h kgblobs.h ktable.h keval.h krepl.h kscript.h kgsystem.h
kgstrings.o: kgstrings.c kstate.h klimits.h klisp.h kobject.h klispconf.h \
ktoken.h kmem.h kapplicative.h koperative.h kcontinuation.h kerror.h \
ksymbol.h kstring.h kghelpers.h kpair.h kgc.h kenvironment.h kgchars.h \
@@ -237,9 +237,12 @@ kreal.o: kreal.c kreal.h kobject.h klimits.h klisp.h klispconf.h kstate.h \
krepl.o: krepl.c klisp.h kobject.h klimits.h klispconf.h kstate.h \
ktoken.h kmem.h kcontinuation.h kenvironment.h kerror.h kread.h kwrite.h \
kstring.h krepl.h ksymbol.h kport.h kpair.h kgc.h ktable.h
+kscript.o: kscript.c klisp.h kobject.h klimits.h klispconf.h kstate.h \
+ ktoken.h kmem.h kcontinuation.h kenvironment.h kerror.h kread.h kwrite.h \
+ kstring.h krepl.h kscript.h ksymbol.h kport.h kpair.h kgc.h ktable.h kgcontrol.h
kstate.o: kstate.c klisp.h kobject.h klimits.h klispconf.h kstate.h \
ktoken.h kmem.h kstring.h kpair.h kgc.h keval.h koperative.h \
- kapplicative.h kcontinuation.h kenvironment.h kground.h krepl.h \
+ kapplicative.h kcontinuation.h kenvironment.h kground.h krepl.h kscript.h \
ksymbol.h kport.h ktable.h kblob.h kgpairs_lists.h kghelpers.h kerror.h
kstring.o: kstring.c kstring.h kobject.h klimits.h klisp.h klispconf.h \
kstate.h ktoken.h kmem.h kgc.h
diff --git a/src/imath.c b/src/imath.c
@@ -3228,7 +3228,8 @@ STATIC mp_result s_udiv(klisp_State *K, mp_int a, mp_int b)
mp_word pfx = r.digits[r.used - 1];
mp_word qdigit;
- if(r.used > 1 && pfx <= btop) {
+ // Bugfix (was pfx <= btop in imath <= 1.17) Andres Navarro
+ if(r.used > 1 && pfx < btop) {
pfx <<= MP_DIGIT_BIT / 2;
pfx <<= MP_DIGIT_BIT / 2;
pfx |= r.digits[r.used - 2];
diff --git a/src/kgblobs.c b/src/kgblobs.c
@@ -43,7 +43,7 @@ void make_blob(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
fill = ivalue(maybe_byte);
}
- if (knegativep(K, tv_s)) {
+ if (knegativep(tv_s)) {
klispE_throw_simple(K, "negative size");
return;
} else if (!ttisfixint(tv_s)) {
diff --git a/src/kgc.c b/src/kgc.c
@@ -109,6 +109,7 @@ static void reallymarkobject (klisp_State *K, GCObject *o)
case K_TPORT:
case K_TTABLE:
case K_TERROR:
+ case K_TBLOB:
o->gch.gclist = K->gray;
K->gray = o;
break;
@@ -583,6 +584,7 @@ static void markroot (klisp_State *K) {
markvalue(K, K->kd_in_port_key);
markvalue(K, K->kd_out_port_key);
markvalue(K, K->kd_error_port_key);
+ markvalue(K, K->kd_strict_arith_key);
markvalue(K, K->empty_string);
markvalue(K, K->empty_blob);
diff --git a/src/kgnumbers.c b/src/kgnumbers.c
@@ -35,9 +35,9 @@
/* Helpers for typed predicates */
bool knumberp(TValue obj) { return ttisnumber(obj); }
-/* TEMP used in =? for type predicate (XXX it's not actually a type
- error, but it's close enough and otherwise should define a
- new bpredp for numeric predicates...) */
+/* TEMP used (as a type predicate) in all predicates that need a primary value
+ (XXX it's not actually a type error, but it's close enough and otherwise
+ should define new predp & bpredp for numeric predicates...) */
bool knumber_wpvp(TValue obj)
{
return ttisnumber(obj) && !ttisrwnpv(obj) && !ttisundef(obj);
@@ -52,9 +52,9 @@ bool kintegerp(TValue obj) { return ttisinteger(obj); }
bool keintegerp(TValue obj) { return ttiseinteger(obj); }
bool krationalp(TValue obj) { return ttisrational(obj); }
bool krealp(TValue obj) { return ttisreal(obj); }
-/* TEMP used in <? & co for type predicate (XXX it's not actually a type
- error, but it's close enough and otherwise should define a
- new bpredp for numeric predicates...) */
+/* TEMP used (as a type predicate) in all predicates that need a real with
+ primary value (XXX it's not actually a type error, but it's close enough
+ and otherwise should define new predp & bpredp for numeric predicates...) */
bool kreal_wpvp(TValue obj) { return ttisreal(obj) && !ttisrwnpv(obj); }
bool kexactp(TValue obj) { return ttisexact(obj); }
@@ -804,9 +804,9 @@ TValue knum_simplest_rational(klisp_State *K, TValue n1, TValue n2)
klispE_throw_simple(K, "x0 doesn't exists (n1 == n2 & "
"irrational)");
return KINERT;
- } else if (knegativep(K, n1) && kpositivep(K, n2)) {
+ } else if (knegativep(n1) && kpositivep(n2)) {
return i2tv(0);
- } else if (knegativep(K, n1)) {
+ } 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
@@ -822,9 +822,9 @@ TValue knum_simplest_rational(klisp_State *K, TValue n1, TValue n2)
if (tv_equal(n1, n2)) {
klispE_throw_simple(K, "result with no primary value");
return KINERT;
- } else if (knegativep(K, n1) && kpositivep(K, n2)) {
+ } else if (knegativep(n1) && kpositivep(n2)) {
return d2tv(0.0);
- } else if (knegativep(K, n1)) {
+ } 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
@@ -950,9 +950,9 @@ void kplus(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
if (!all_zero)
cres = KRWNPV; /* check is made later */
} else if (all_exact)
- cres = knegativep(K, cres)? KEMINF : KEPINF;
+ cres = knegativep(cres)? KEMINF : KEPINF;
else
- cres = knegativep(K, cres)? KIMINF : KIPINF;
+ cres = knegativep(cres)? KIMINF : KIPINF;
/* here if any of the two has no primary an error is signaled */
res = knum_plus(K, ares, cres);
@@ -1011,7 +1011,7 @@ void ktimes(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
; /* do nothing */
if (kfast_zerop(cres))
; /* do nothing */
- else if (kpositivep(K, cres) && knum_ltp(K, cres, i2tv(1))) {
+ else if (kpositivep(cres) && knum_ltp(K, cres, i2tv(1))) {
if (all_exact)
cres = i2tv(0);
else
@@ -1104,9 +1104,9 @@ void kminus(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
if (!all_zero)
cres = KRWNPV; /* check is made later */
} else if (all_exact)
- cres = knegativep(K, cres)? KEMINF : KEPINF;
+ cres = knegativep(cres)? KEMINF : KEPINF;
else
- cres = knegativep(K, cres)? KIMINF : KIPINF;
+ cres = knegativep(cres)? KIMINF : KIPINF;
/* here if any of the two has no primary an error is signaled */
res = knum_plus(K, ares, cres);
@@ -1356,7 +1356,7 @@ void kdiv_mod(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
/* use ftyped_predp */
/* Helpers for positive?, negative?, odd? & even? */
-bool kpositivep(klisp_State *K, TValue n)
+bool kpositivep(TValue n)
{
switch (ttype(n)) {
case K_TFIXINT:
@@ -1369,17 +1369,15 @@ bool kpositivep(klisp_State *K, TValue n)
return kbigrat_positivep(n);
case K_TDOUBLE:
return dvalue(n) > 0.0;
- case K_TRWNPV:
- klispE_throw_simple_with_irritants(K, "no primary value", 1, n);
- return false;
- /* complex and undefined should be captured by type predicate */
+ /* real with no prim value, complex and undefined should be captured by
+ type predicate */
default:
- klispE_throw_simple(K, "unsupported type");
+ klisp_assert(0);
return false;
}
}
-bool knegativep(klisp_State *K, TValue n)
+bool knegativep(TValue n)
{
switch (ttype(n)) {
case K_TFIXINT:
@@ -1392,12 +1390,10 @@ bool knegativep(klisp_State *K, TValue n)
return kbigrat_negativep(n);
case K_TDOUBLE:
return dvalue(n) < 0.0;
- case K_TRWNPV:
- klispE_throw_simple_with_irritants(K, "no primary value", 1, n);
- return false;
- /* complex and undefined should be captured by type predicate */
+ /* real with no prim value, complex and undefined should be captured by
+ type predicate */
default:
- klispE_throw_simple(K, "unsupported type");
+ klisp_assert(0);
return false;
}
}
@@ -1412,6 +1408,8 @@ bool koddp(TValue 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 */
default:
assert(0);
return false;
@@ -1427,6 +1425,8 @@ bool kevenp(TValue 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 */
default:
assert(0);
return false;
@@ -1745,7 +1745,7 @@ void kdivided(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
; /* do nothing */
if (kfast_zerop(cres))
; /* do nothing */
- else if (kpositivep(K, cres) && knum_ltp(K, cres, i2tv(1))) {
+ else if (kpositivep(cres) && knum_ltp(K, cres, i2tv(1))) {
if (all_exact)
cres = i2tv(0);
else
@@ -1870,7 +1870,7 @@ void kexp(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
}
case K_TEINF: /* in any case return inexact result (e is inexact) */
case K_TIINF:
- res = kpositivep(K, n)? KIPINF : d2tv(0.0);
+ res = kpositivep(n)? KIPINF : d2tv(0.0);
break;
case K_TRWNPV:
case K_TUNDEFINED:
@@ -1895,7 +1895,7 @@ void klog(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
if (kfast_zerop(n)) {
klispE_throw_simple_with_irritants(K, "zero argument", 1, n);
return;
- } else if (knegativep(K, n)) {
+ } else if (knegativep(n)) {
klispE_throw_simple_with_irritants(K, "negative argument", 1, n);
return;
}
@@ -2083,7 +2083,7 @@ void katan(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
}
} else {
/* XXX either pi/2 or -pi/2, but we don't have the constant */
- double d = kpositivep(K, n1)? atan(INFINITY) : atan(-INFINITY);
+ double d = kpositivep(n1)? atan(INFINITY) : atan(-INFINITY);
res = ktag_double(d);
}
break;
@@ -2131,7 +2131,7 @@ void ksqrt(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
}
case K_TEINF:
case K_TIINF:
- res = knegativep(K, n)? KUNDEF : KIPINF;
+ res = knegativep(n)? KUNDEF : KIPINF;
break;
case K_TRWNPV:
case K_TUNDEFINED:
@@ -2174,15 +2174,15 @@ void kexpt(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
case K_TEINF:
case K_TIINF:
if (ttisinf(n1) && ttisinf(n2)) {
- if (knegativep(K, n1) && knegativep(K, n2))
+ if (knegativep(n1) && knegativep(n2))
res = d2tv(0.0);
- else if (knegativep(K, n1) || knegativep(K, n2))
+ else if (knegativep(n1) || knegativep(n2))
res = KUNDEF; /* ASK John: is this ok? */
else
res = KIPINF;
} else if (ttisinf(n1)) {
- if (knegativep(K, n1)) {
- if (knegativep(K, n2))
+ if (knegativep(n1)) {
+ if (knegativep(n2))
res = d2tv(0.0);
else {
TValue num = knum_numerator(K, n2);
@@ -2194,9 +2194,9 @@ void kexpt(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
res = KIPINF;
}
} else { /* ttisinf(n2) */
- if (knegativep(K, n2))
+ if (knegativep(n2))
res = d2tv(0.0);
- else if (knegativep(K, n1))
+ else if (knegativep(n1))
res = KUNDEF; /* ASK John: is this ok? */
else
res = KIPINF;
@@ -2226,7 +2226,7 @@ void kinit_numbers_ground_env(klisp_State *K)
add_applicative(K, ground_env, "number?", ftypep, 2, symbol,
p2tv(knumberp));
add_applicative(K, ground_env, "finite?", ftyped_predp, 3, symbol,
- p2tv(knumberp), p2tv(kfinitep));
+ p2tv(knumber_wpvp), p2tv(kfinitep));
add_applicative(K, ground_env, "integer?", ftypep, 2, symbol,
p2tv(kintegerp));
/* 12.5.2 =? */
@@ -2249,7 +2249,7 @@ 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(knumberp), 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));
@@ -2266,9 +2266,9 @@ void kinit_numbers_ground_env(klisp_State *K)
i2tv(FDIV_ZERO | FDIV_DIV | FDIV_MOD));
/* 12.5.10 positive?, negative? */
add_applicative(K, ground_env, "positive?", ftyped_predp, 3, symbol,
- p2tv(krealp), p2tv(kpositivep));
+ p2tv(kreal_wpvp), p2tv(kpositivep));
add_applicative(K, ground_env, "negative?", ftyped_predp, 3, symbol,
- p2tv(krealp), 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));
diff --git a/src/kgnumbers.h b/src/kgnumbers.h
@@ -84,8 +84,8 @@ bool kzerop(TValue n);
/* use ftyped_predp */
/* Helpers for positive?, negative?, odd? & even? */
-bool kpositivep(klisp_State *K, TValue n);
-bool knegativep(klisp_State *K, TValue n);
+bool kpositivep(TValue n);
+bool knegativep(TValue n);
bool koddp(TValue n);
bool kevenp(TValue n);
@@ -218,7 +218,7 @@ inline TValue kneg_inf(TValue i)
inline bool knum_same_signp(klisp_State *K, TValue n1, TValue n2)
{
- return kpositivep(K, n1) == kpositivep(K, n2);
+ return kpositivep(n1) == kpositivep(n2);
}
/* init ground */
diff --git a/src/kgpair_mut.c b/src/kgpair_mut.c
@@ -170,7 +170,7 @@ void encycleB(klisp_State *K, TValue *xparams, TValue ptree,
"exact integer", keintegerp, tk1,
"exact integer", keintegerp, tk2);
- if (knegativep(K, tk1) || knegativep(K, tk2)) {
+ if (knegativep(tk1) || knegativep(tk2)) {
klispE_throw_simple(K, "negative index");
return;
}
diff --git a/src/kgpairs_lists.c b/src/kgpairs_lists.c
@@ -241,7 +241,7 @@ void list_tail(klisp_State *K, TValue *xparams, TValue ptree,
bind_2tp(K, ptree, "any", anytype, obj,
"exact integer", keintegerp, tk);
- if (knegativep(K, tk)) {
+ if (knegativep(tk)) {
klispE_throw_simple(K, "negative index");
return;
}
@@ -294,7 +294,7 @@ void list_ref(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
bind_2tp(K, ptree, "any", anytype, obj,
"exact integer", keintegerp, tk);
- if (knegativep(K, tk)) {
+ if (knegativep(tk)) {
klispE_throw_simple(K, "negative index");
return;
}
diff --git a/src/kgports.c b/src/kgports.c
@@ -25,6 +25,8 @@
#include "kwrite.h"
#include "kpair.h"
+#include "kscript.h"
+
#include "kghelpers.h"
#include "kgports.h"
#include "kgcontinuations.h" /* for guards */
@@ -329,6 +331,10 @@ void call_with_file(klisp_State *K, TValue *xparams, TValue ptree,
/* GC: assume port is rooted */
TValue read_all_expr(klisp_State *K, TValue port)
{
+ /* support unix script directive #! */
+ int line_count = kscript_eat_directive(kport_file(port));
+ kport_line(port) += line_count;
+
/* GC: root dummy and obj */
TValue tail = kget_dummy1(K);
TValue obj = KINERT;
diff --git a/src/kground.c b/src/kground.c
@@ -43,6 +43,7 @@
#include "kstring.h"
#include "keval.h"
#include "krepl.h"
+#include "kscript.h"
/* for init_cont_names */
#define add_cont_name(K_, t_, c_, n_) \
@@ -67,6 +68,10 @@ void kinit_cont_names(klisp_State *K)
add_cont_name(K, t, do_repl_loop, "repl-loop");
add_cont_name(K, t, do_repl_error, "repl-report-error");
+ /* SCRIPT, root-continuation & error-continuation */
+ add_cont_name(K, t, do_script_exit, "script-exit");
+ add_cont_name(K, t, do_script_error, "script-report-error");
+
/* GROUND ENV */
add_cont_name(K, t, do_eval_ls, "eval-list");
add_cont_name(K, t, do_combine, "eval-combine");
diff --git a/src/kgstrings.c b/src/kgstrings.c
@@ -41,7 +41,7 @@ void make_string(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
if (get_opt_tpar(K, "make-string", K_TCHAR, &maybe_char))
fill = chvalue(maybe_char);
- if (knegativep(K, tv_s)) {
+ if (knegativep(tv_s)) {
klispE_throw_simple(K, "negative size");
return;
} else if (!ttisfixint(tv_s)) {
diff --git a/src/klisp.c b/src/klisp.c
@@ -15,16 +15,22 @@
#include "klisp.h"
#include "kstate.h"
#include "kauxlib.h"
+#include "kscript.h"
int main(int argc, char *argv[])
{
- printf("REPL Test\n");
-
- klisp_State *K = klispL_newstate();
- klispS_init_repl(K);
- klispS_run(K);
- klisp_close(K);
-
- printf("Done!\n");
- return 0;
+ if (argc <= 1) {
+ klisp_State *K = klispL_newstate();
+ klispS_init_repl(K);
+ klispS_run(K);
+ klisp_close(K);
+ return 0;
+ } else {
+ klisp_State *K = klispL_newstate();
+ kinit_script(K, argc - 1, argv + 1);
+ klispS_run(K);
+ int exit_code = K->script_exit_code;
+ klisp_close(K);
+ return exit_code;
+ }
}
diff --git a/src/krational.c b/src/krational.c
@@ -492,14 +492,16 @@ TValue kbigrat_to_integer(klisp_State *K, TValue tv_bigrat, kround_mode mode)
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:
+ case K_ROUND_EVEN: {
UNUSED(mp_int_mul_pow2(K, rest, 1, rest));
- if (mp_int_compare(rest, MP_DENOM_P(n)) == 0 &&
- mp_int_is_odd(quot))
+ 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;
}
+ }
krooted_tvs_pop(K);
krooted_tvs_pop(K);
diff --git a/src/kread.c b/src/kread.c
@@ -528,6 +528,10 @@ TValue kread_from_port(klisp_State *K, TValue port, bool mut)
TValue kread_peek_char_from_port(klisp_State *K, TValue port, bool peek)
{
+ /* Reset the EOF flag in the tokenizer. The flag is shared,
+ by operations on all ports. */
+ K->ktok_seen_eof = false;
+
K->curr_port = port;
K->curr_in = kport_file(port);
int ch;
diff --git a/src/kreal.c b/src/kreal.c
@@ -731,6 +731,7 @@ TValue kdouble_to_integer(klisp_State *K, TValue tv_double, kround_mode mode)
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/kscript.c b/src/kscript.c
@@ -0,0 +1,268 @@
+/*
+** kscript.c
+** klisp noninteractive script execution
+** See Copyright Notice in klisp.h
+*/
+#include <stdio.h>
+#include <setjmp.h>
+
+#include "klisp.h"
+#include "kstate.h"
+#include "kobject.h"
+#include "kcontinuation.h"
+#include "kenvironment.h"
+#include "kerror.h"
+#include "kread.h"
+#include "kwrite.h"
+#include "kstring.h"
+#include "krepl.h"
+#include "kscript.h"
+#include "ksymbol.h"
+#include "kport.h"
+#include "kpair.h"
+#include "kgcontrol.h"
+/* for names */
+#include "ktable.h"
+
+/* Push (v) in GC roots and return (v). */
+static inline TValue krooted_tvs_pass(klisp_State *K, TValue v)
+{
+ krooted_tvs_push(K, v);
+ return v;
+}
+
+#if KTRACK_SI
+static inline TValue krooted_tvs_pass_si(klisp_State *K, TValue v, TValue si)
+{
+ krooted_tvs_push(K, v);
+ kset_source_info(K, v, si);
+ return v;
+}
+#endif
+
+/* the exit continuation, it exits the loop */
+void do_script_exit(klisp_State *K, TValue *xparams, TValue obj)
+{
+ UNUSED(xparams);
+
+ /* save exit code */
+
+ switch(ttype(obj)) {
+ case K_TINERT:
+ K->script_exit_code = 0;
+ break;
+ case K_TFIXINT:
+ K->script_exit_code = (int) ivalue(obj);
+ break;
+ default:
+ K->script_exit_code = KSCRIPT_DEFAULT_ERROR_EXIT_CODE;
+ /* TODO: print error message here ? */
+ break;
+ }
+
+ /* force the loop to terminate */
+ K->next_func = NULL;
+ return;
+}
+
+
+/* the underlying function of the error cont */
+void do_script_error(klisp_State *K, TValue *xparams, TValue obj)
+{
+ /*
+ ** xparams[0]: dynamic environment
+ */
+
+ /* FOR NOW used only for irritant list */
+ TValue port = kcdr(K->kd_error_port_key);
+ klisp_assert(kport_file(port) == stderr);
+
+ /* 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);
+#if KTRACK_NAMES
+ } 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);
+
+#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);
+#endif
+#endif
+ krooted_tvs_pop(K);
+ } else {
+ fprintf(stderr, "\n*ERROR*: not an error object passed to "
+ "error continuation");
+ }
+
+ /* Save the exit code to be returned from interpreter
+ main(). Terminate the interpreter loop. */
+
+ K->script_exit_code = KSCRIPT_DEFAULT_ERROR_EXIT_CODE;
+ K->next_func = NULL;
+}
+
+/* convert C style argc-argv pair to list of strings */
+static TValue argv2value(klisp_State *K, int argc, char *argv[])
+{
+ TValue dummy = kcons_g(K, false, KINERT, KNIL);
+ krooted_tvs_push(K, dummy);
+ TValue tail = dummy;
+ for (int i = 0; i < argc; i++) {
+ TValue next_car = kstring_new_b_imm(K, argv[i]);
+ krooted_tvs_push(K, next_car);
+ TValue np = kcons_g(K, false, next_car, KNIL);
+ krooted_tvs_pop(K);
+ kset_cdr_unsafe(K, tail, np);
+ tail = np;
+ }
+ krooted_tvs_pop(K);
+ return kcdr(dummy);
+}
+
+/* loader_body(K, ARGV, DENV) returns the value
+ *
+ * ((load (car ARGV))
+ * ($if ($binds? DENV main) (main ARGV) #inert)
+ *
+ */
+static TValue loader_body(klisp_State *K, TValue argv, TValue denv)
+{
+ int32_t rooted_tvs_mark = K->rooted_tvs_top;
+# define S(z) (krooted_tvs_pass(K, ksymbol_new(K, (z), KNIL)))
+# define C(car, cdr) (krooted_tvs_pass(K, kcons_g(K, false, (car), (cdr))))
+# define L(n, ...) (krooted_tvs_pass(K, klist_g(K, false, (n), __VA_ARGS__)))
+ TValue main_sym = S("main");
+ TValue script_name = krooted_tvs_pass(K, kcar(argv));
+ TValue body =
+ L(2, L(2, S("load"), script_name),
+ L(4, S("$if"), L(3, S("$binds?"), denv, main_sym),
+ L(2, main_sym, C(S("list"), argv)),
+ KINERT));
+# undef S
+# undef L
+ K->rooted_tvs_top = rooted_tvs_mark;
+ return body;
+}
+
+/* call this to init the noninteractive mode */
+
+void kinit_script(klisp_State *K, int argc, char *argv[])
+{
+# define R(z) (krooted_tvs_pass(K, (z)))
+# define G(z, sym) \
+ do { TValue symbol = ksymbol_new(K, (sym), KNIL); \
+ krooted_tvs_push(K, symbol); \
+ kadd_binding(K, K->ground_env, symbol, (z)); \
+ krooted_tvs_pop(K); \
+ } while (0)
+
+#if KTRACK_SI
+ TValue str = R(kstring_new_b_imm(K, __FILE__));
+ TValue tail = R(kcons(K, i2tv(__LINE__), i2tv(0)));
+ TValue si = kcons(K, str, tail);
+ krooted_tvs_pop(K);
+ krooted_tvs_pop(K);
+ krooted_tvs_push(K, si);
+# define RSI(z) (krooted_tvs_pass_si(K, (z), si))
+#else
+# define RSI(z) R(z)
+#endif
+
+ TValue std_env = RSI(kmake_environment(K, K->ground_env));
+ TValue root_cont = RSI(kmake_continuation(K, KNIL, do_script_exit, 0));
+ TValue error_cont = RSI(kmake_continuation(K, root_cont, do_script_error, 1, std_env));
+ G(root_cont, "root-continuation");
+ G(error_cont, "error-continuation");
+ K->root_cont = root_cont;
+ K->error_cont = error_cont;
+ krooted_tvs_pop(K);
+ krooted_tvs_pop(K);
+
+ TValue argv_value = RSI(argv2value(K, argc, argv));
+ TValue loader = RSI(loader_body(K, argv_value, std_env));
+ TValue loader_cont = RSI(kmake_continuation(K, root_cont, do_seq, 2, loader, std_env));
+ kset_cc(K, loader_cont);
+ krooted_tvs_pop(K);
+ krooted_tvs_pop(K);
+ krooted_tvs_pop(K);
+ krooted_tvs_pop(K);
+#if KTRACK_SI
+ krooted_tvs_pop(K);
+#endif
+ kapply_cc(K, KINERT);
+
+#undef R
+#undef RSI
+#undef G
+}
+
+/* skips the unix script directive (#!), if present.
+ returns number of lines skipped */
+int kscript_eat_directive(FILE *fr)
+{
+ static const char pattern[] = "#! ";
+ int c, n = 0;
+
+ while (pattern[n] != '\0' && (c = getc(fr), c == pattern[n]))
+ n++;
+
+ if (pattern[n] == '\0') {
+ while (c = getc(fr), c != EOF && c != '\n')
+ ;
+ return 1;
+ } else {
+ ungetc(c, fr);
+ /* XXX/Temp notice that the standard doesn't guarantee that more than one
+ ungetc in a row will be honored. Andres Navarro */
+ while (n > 0)
+ ungetc(pattern[--n], fr);
+ return 0;
+ }
+}
diff --git a/src/kscript.h b/src/kscript.h
@@ -0,0 +1,28 @@
+/*
+** krepl.h
+** klisp noninteractive script execution
+** See Copyright Notice in klisp.h
+*/
+
+#ifndef kscript_h
+#define kscript_h
+
+#include <stdio.h>
+#include "klisp.h"
+#include "kstate.h"
+#include "kobject.h"
+
+void kinit_script(klisp_State *K, int argc, char *argv[]);
+
+/* continuation functions */
+void do_script_exit(klisp_State *K, TValue *xparams, TValue obj);
+void do_script_error(klisp_State *K, TValue *xparams, TValue obj);
+
+/* unix script directive handling */
+int kscript_eat_directive(FILE *fr);
+
+/* default exit code in case of error according to SRFI-22 */
+
+#define KSCRIPT_DEFAULT_ERROR_EXIT_CODE 70
+
+#endif
diff --git a/src/kstate.c b/src/kstate.c
@@ -30,6 +30,7 @@
#include "kenvironment.h"
#include "kground.h"
#include "krepl.h"
+#include "kscript.h"
#include "ksymbol.h"
#include "kstring.h"
#include "kport.h"
@@ -187,6 +188,9 @@ klisp_State *klisp_newstate (klisp_Alloc f, void *ud) {
/* initialize writer */
K->write_displayp = false; /* set on each call to write */
+ /* initialize script */
+ K->script_exit_code = KSCRIPT_DEFAULT_ERROR_EXIT_CODE;
+
/* initialize temp stack */
K->ssize = KS_ISSIZE;
K->stop = 0; /* stack is empty */
diff --git a/src/kstate.h b/src/kstate.h
@@ -139,6 +139,9 @@ struct klisp_State {
/* writer */
bool write_displayp;
+ /* script */
+ int script_exit_code;
+
/* auxiliary stack */
int32_t ssize; /* total size of array */
int32_t stop; /* top of the stack (all elements are below this index) */
diff --git a/src/kwrite.c b/src/kwrite.c
@@ -517,7 +517,8 @@ void kwrite_fsm(klisp_State *K, TValue obj)
}
case K_TSTRING: {
if (kstring_emptyp(obj)) {
- kw_printf(K, "\"\"");
+ if (!K->write_displayp)
+ kw_printf(K, "\"\"");
} else {
TValue mark = kget_mark(obj);
if (K->write_displayp || ttisboolean(mark)) {
diff --git a/src/tests/numbers.k b/src/tests/numbers.k
@@ -0,0 +1,417 @@
+;; check.k & test-helpers.k should be loaded
+;;
+;; I fixed all of the bugs and added some rationale to some of the tests
+;; marked as FAIL. In some cases, as you say, the specification is unclear.
+;; In these cases I tried to include my interpretation (which could be wrong),
+;; and changed the test to reflect this.
+;;
+;; I am inclined to wait for the next revision of the report before working
+;; too much with numeric features, but some of these could be asked to John
+;; Shutt for clarification (but I warn you that while he is very cooperative
+;; with this kind of things he sometimes takes a while to answer).
+;;
+;; The round thing was actually a bug in the IMath division routine
+;; I fixed it (I think!) and have sent an email to the maintainer to
+;; report the bug and hopefully confirm the correctness of the fix
+;;
+;; Andres Navarro
+;;
+;; Please look for the keyword FAIL in the source code.
+;; The marked lines include
+;; - failing tests
+;; - tests corresponding to incorrect or unclear specification
+;;
+;; Other bugs:
+;;
+;; - evaluating
+;;
+;; ($check equal? (round -1.1) -1)
+;; freezes the interpreter
+;;
+
+;; 12.4 External representation of numbers.
+;;
+;; check various formats against plain decimals
+;;
+
+($check equal? #d000 0)
+($check equal? #d099 99)
+($check equal? #d-099 -99)
+($check equal? #d35/67 35/67)
+
+($check equal? #x00 0)
+($check equal? #x0FF 255)
+($check equal? #x-0FF -255)
+($check equal? #x-AB/CD -171/205)
+
+($check equal? #b00000 0)
+($check equal? #b01111 15)
+($check equal? #b-01111 -15)
+($check equal? #b#e101 5)
+
+($check equal? #o0000 0)
+($check equal? #o0777 511)
+($check equal? #o-0777 -511)
+($check equal? #e#o-16 -14)
+
+($check equal? #e-infinity #e-infinity)
+($check equal? #e+infinity #e+infinity)
+($check equal? #i-infinity #i-infinity)
+($check equal? #i+infinity #i+infinity)
+
+;; 12.5.1 number? finite? integer?
+
+($check-predicate (number? 0 1 3/5 -3.14e0 #real))
+($check-not-predicate (number? 5 "6" 7))
+
+($check-predicate (finite? 0 1/3 -99999999))
+($check-not-predicate (finite? #e+infinity))
+($check-not-predicate (finite? #e-infinity))
+
+($check-error (finite? #real))
+($check-error (finite? #undefined))
+
+($check-predicate (integer? 0 8/2 -12/6 1.0 -1.25e2))
+($check-not-predicate (integer? #e+infinity))
+($check-not-predicate (integer? #e-infinity))
+($check-not-predicate (integer? #real))
+($check-not-predicate (integer? "0"))
+
+;; 12.5.2 =?
+
+($check-predicate (=?))
+($check-predicate (=? -1))
+($check-predicate (=? 0 0.0 0/1 -0.0 -0/1))
+($check-predicate (=? #e+infinity #e+infinity))
+($check-predicate (=? #e-infinity #e-infinity))
+($check-predicate (=? . #0=(1 . #0#)))
+($check-not-predicate (=? 0 1))
+($check-not-predicate (=? 1 #e-infinity))
+($check-not-predicate (=? #e+infinity #e-infinity))
+($check-not-predicate (=? 2 5/2))
+($check-not-predicate (=? . #0=(1 2 . #0#)))
+($check-error (=? 0 #f))
+($check-error (=? 1 #t))
+($check-error (=? #real #real))
+($check-error (=? 1 #real))
+($check-error (=? #real -1/2))
+($check-error (=? #real #e+infinity))
+
+;; 12.5.3 <? <=? >=? >?
+
+($check-predicate (<?))
+($check-predicate (<? 1))
+($check-predicate (<? 1 3 7 15))
+($check-not-predicate (<? 1 7 3 7 15))
+($check-predicate (<? #e-infinity -1 0 1 #e+infinity))
+
+;; 12.5.4 +
+
+($check equal? (+ 1 1) 2)
+($check equal? (+) 0)
+($check equal? (+ . #0=(0 . #0#)) 0)
+($check equal? (+ . #0=(1 . #0#)) #e+infinity)
+($check equal? (+ . #0=(-1 . #0#)) #e-infinity)
+($check equal? (+ . #0=(1 -1 . #0#)) #real)
+
+;; 12.5.5 *
+
+($check equal? (* 2 3) 6)
+($check equal? (*) 1)
+($check equal? (* 0 #e+infinity) #real)
+($check equal? (* 0 #e-infinity) #real)
+($check equal? (* . #0=(1 . #0#)) 1)
+($check equal? (* . #0=(2 . #0#)) #e+infinity)
+($check equal? (* . #0=(1/2 . #0#)) 0)
+($check equal? (* . #0=(1/2 2 . #0#)) #real)
+($check equal? (* . #0=(-1 . #0#)) #real)
+
+;; 12.5.5 -
+
+($check equal? (- 5 3) 2)
+($check-error (-))
+($check-error (- 0))
+
+;; 12.5.7 zero?
+
+($check-predicate (zero? 0 0/1 -0 -0/1 0.0 -0.0 #i0))
+($check-not-predicate (zero? 1))
+($check-not-predicate (zero? -0.0001))
+($check-not-predicate (zero? #e+infinity))
+($check-not-predicate (zero? #e-infinity))
+($check-error (zero? #real))
+($check-error (zero? #undefined))
+
+;; 12.5.8 div, mod, div-and-mod
+
+($check equal? (div 10 2) 5)
+($check equal? (div -10 2) -5)
+($check equal? (div 10 -2) -5)
+($check equal? (div -10 -2) 5)
+
+($check equal? (div 10 7) 1)
+($check equal? (div -10 7) -2)
+
+;; (div real1 real2) ... Let n be the greatest integer such that
+;; real2 * n <= real1. Applicative div returns n.
+;;
+;; If real2 is negative, then such integer n does not exist.
+;; interpretation : result shall be #undefined
+;;
+;; I followed Scheme r6rs and r7rs draft here. The definition in the
+;; Kernel report didn't make much sense to me. I'm still waiting the
+;; 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? (mod 10 7) 3)
+($check equal? (div-and-mod 10 7) (list 1 3))
+
+;; 12.5.9 div0, mod0, div-and-mod0
+;; Test cases from R6RS. The commented test cases
+;; 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 -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))
+
+;; 12.5.10 positive? negative?
+
+($check-predicate (positive? 1 1.0 1/1 999999999999 #e+infinity))
+($check-not-predicate (positive? 0))
+($check-not-predicate (positive? #e-infinity))
+($check-error (positive? #real))
+($check-error (positive? #undefined))
+
+($check-predicate (negative? -1 -1.0 -1/1 -999999999999 #e-infinity))
+($check-not-predicate (negative? 0))
+($check-not-predicate (negative? #e+infinity))
+($check-error (negative? #real))
+($check-error (negative? #undefined))
+
+;; 12.5.11 even? odd?
+
+($check-predicate (even? 0 2 -2 4/2 9999999999998))
+($check-error (even? #e+infinity))
+($check-error (even? #e-infinity))
+
+($check-predicate (odd? 1 -1 6/2 9999999999999))
+($check-error (odd? #e+infinity))
+($check-error (odd? #e-infinity))
+
+;; 12.5.12 abs
+
+($check equal? (abs 0) 0)
+($check equal? (abs 1) 1)
+($check equal? (abs -1) 1)
+($check equal? (abs #e+infinity) #e+infinity)
+($check equal? (abs #e-infinity) #e+infinity)
+
+;; 12.5.12 max min
+
+($check equal? (max) #e-infinity)
+($check equal? (max 1 2 3 4) 4)
+($check equal? (max #e-infinity #e+infinity) #e+infinity)
+
+($check equal? (min) #e+infinity)
+($check equal? (min 1 2 3 4) 1)
+($check equal? (min #e-infinity #e+infinity) #e-infinity)
+
+;; 12.5.12 lcm gcd
+;; TODO
+
+;; 12.6.1 exact? inexact? robust? undefined?
+
+($check-predicate (exact? 0 1 -1 1/2 999999999999 #e-infinity))
+($check-not-predicate (exact? 3.14))
+($check-not-predicate (exact? #i-infinity))
+($check-not-predicate (exact? #real))
+($check-not-predicate (exact? #undefined))
+
+($check-predicate (inexact? #real 3.14 #undefined #i+infinity))
+($check-not-predicate (inexact? 0))
+($check-not-predicate (inexact? #e+infinity))
+
+($check-predicate (robust? 0 1 -1 1/3 999999999999 #e-infinity #e+infinity))
+;; For now klisp doesn't support precise bounds or robust tagging of inexact
+;; numbers. This is, however, allowed by the report (see section 12.2,
+;; Inexactness):
+;;
+;; "(...) The implementation might simply take all inexact real numbers
+;; to be non-robust with upper bound positive infinity and lower bound
+;; negative infinity (...)"
+;;
+;; Andres Navarro
+;; was ($check-predicate (robust? 3.14)) ; FAIL
+($check-not-predicate (robust? #real))
+($check-not-predicate (robust? #undefined))
+
+($check-predicate (undefined? #undefined))
+($check-not-predicate (undefined? 0))
+
+;; 12.6.2 get-real-internal-bounds get-real-exact-bounds
+;; TODO: How to test it?
+($check equal? (get-real-internal-bounds 0) (list 0 0))
+($check equal? (get-real-exact-bounds 0) (list 0 0))
+
+;; 12.6.3 get-real-internal-primary get-real-exact-primary
+;; TODO: How to test it?
+
+;; 12.6.4 make-inexact
+;; TODO
+
+;; 12.6.5 real->inexact real->exact
+;; TODO
+
+;; 12.6.6 with-strict-arithmetic get-strict-arithmetic?
+;; TODO
+
+;; 12.7.1 with-narrow-arithmetic get-narrow-arithmetic?
+;; TODO
+
+;; 12.8.1 rational?
+
+($check-predicate (rational? 0 1 1/2))
+;; For now (and probably forever) klisp doesn't support non-rational
+;; reals. While this is certainly doable it implies the use of a complex
+;; algebraic module that is well beyond the scope of this project.
+;; See following paragraph from the report: "It would seem a daunting task to
+;; implement module Real without module Inexact, but in case someone has a
+;; reason to do so, the report doesn’t preclude it, i.e., module Real doesn’t
+;; assume module Inexact."
+;;
+;; Then, in section 12.2, Inexactness, it says: " However, sometimes
+;; there may be no way for an internal number to capture a mathematical
+;; number that the client wants to reason about, either because the intended
+;; mathematical number cannot be represented by an internal number (as with
+;; exclusively rational internal number formats confronted with an irrational
+;; mathematical number) ..."
+;; and then on the definition of rational? (12.8.1)
+;; "An inexact real is a rational iff its primary value is a ratio of
+;; integers." which is true of all finite reals supported by klisp
+;; as they are represented in floating point format and are therefore
+;; expressible by the formula (sign + or -) mantissa / 2 ^ (-expt)
+;;
+;; Andres Navarro
+; was ($check-not-predicate (rational? (sqrt 2))) ; FAIL
+($check-not-predicate (rational? #e+infinity))
+
+;; 12.8.2 /
+
+($check equal? (/ 2 3) 2/3)
+($check equal? (/ 1 2 3) 1/6)
+($check-error (/ 1 0))
+($check-error (/ #e+infinity #e+infinity))
+
+;; 12.8.3 numerator denominator
+
+($check equal? (numerator 3/4) 3)
+($check equal? (numerator -3/4) -3)
+($check equal? (denominator 3/4) 4)
+($check equal? (denominator -3/4) 4)
+
+;; 12.8.4 floor ceiling truncate bound
+
+;; By my interpretation of the report, these applicatives return inexact
+;; integers (they could in principle return exact integers if the reals
+;; passed were correctly bounded, and this is the case in klisp for exact
+;; rationals for example, but not for inexact reals in general). The report
+;; only says that exact arguments means exact results (when possible).
+;; I could be wrong of course, I should consult this with John Shutt
+;;
+;; Andres Navarro
+
+($check equal? (floor 0) 0)
+($check equal? (floor #e1.23) 1)
+($check equal? (floor #e-1.23) -2)
+($check =? (floor 1.23) 1)
+($check =? (floor -1.23) -2)
+
+($check equal? (ceiling 0) 0)
+($check equal? (ceiling #e1.23) 2)
+($check equal? (ceiling #e-1.23) -1)
+($check =? (ceiling 1.23) 2)
+($check =? (ceiling -1.23) -1)
+
+($check equal? (truncate 0) 0)
+($check equal? (truncate #e1.99) 1)
+($check equal? (truncate #e-1.99) -1)
+($check =? (truncate 1.99) 1)
+($check =? (truncate -1.99) -1)
+
+($check equal? (round 0) 0)
+($check equal? (round 1/2) 0)
+($check equal? (round #e1.1) 1)
+($check =? (round 1.1) 1)
+($check equal? (round 3/2) 2)
+($check equal? (round #e1.9) 2)
+($check =? (round 1.9) 2)
+($check equal? (round -1/2) 0)
+($check =? (round #e-1.1) -1)
+($check equal? (round #e-1.1) -1)
+($check equal? (round -3/2) -2)
+($check equal? (round #e-1.9) -2)
+($check =? (round -1.9) -2)
+
+;; 12.8.5 rationalize simplest-rational
+
+($check equal? (rationalize 0 1) 0)
+
+;; I would think the same as for floor, truncate, etc apply here
+;; Here the reports even says this explicitly, in 12.8.5:
+;; "If real1 and real2 are exact, the applicative (whichever it is)
+;; returns exact x0. If one or both of real1 and real2 are inexact,
+;; the applicative returns an inexact approximating x0
+;; (as by real->inexact , §12.6.5).
+;;
+;; Andres Navarro
+
+;; (I think you meant 1/7 here, 1/6 is about 0.16, and so, outside the range)
+;;
+;; Andres Navarro
+;; was ($check equal? (rationalize 0.1 0.05) 1/6) ; FAIL
+($check =? (rationalize 0.1 0.05) 1/7)
+($check equal? (rationalize #e0.1 #e0.05) 1/7)
+
+($check equal? (simplest-rational 2/7 3/5) 1/2)
+($check =? (simplest-rational 0.1 0.3) 1/4)
+($check equal? (simplest-rational #e0.1 #e0.3) 1/4)
+
+;; 12.9.1 real?
+
+($check-predicate (real? 0 1 -1 1/2 999999999999 #e-infinity))
+($check-not-predicate (real? #undefined))
+
+;; 12.9.2 exp log
+;; These functions are not described in the Report, but let us try...
+
+($check equal? (exp 0.0) 1.0)
+($check equal? (log 1.0) 0.0)
+
+;; 12.9.2 sin cos tan
+($check equal? (sin 0.0) 0.0)
+($check equal? (cos 0.0) 1.0)
+($check equal? (tan 0.0) 0.0)
+
+;; 12.9.2 asin acos atan
+($check equal? (asin 0.0) 0.0)
+($check equal? (acos 1.0) 0.0)
+($check equal? (atan 0.0) 0.0)
+
+;; 12.9.5 sqrt
+($check equal? (sqrt 0.0) 0.0)
+($check equal? (sqrt 1.0) 1.0)
+($check equal? (sqrt 4.0) 2.0)
+
+;; 12.9.6 expt
+($check equal? (expt 2.0 4.0) 16.0)
+
+;; 12.10 Complex features
+;; not implemented
diff --git a/src/tests/ports.k b/src/tests/ports.k
@@ -0,0 +1,178 @@
+;; check.k & test-helpers.k should be loaded
+;;
+;; Tests of i/o features.
+;;
+;; TODO: Make the test portable.
+;; TODO: Delete temporary files.
+
+;; Utilities for testing input and output features.
+;;
+;; temp-file .......... temporary file for input and output
+;; test-input-file .... pre-existing file for input
+;; nonexistent-file ... valid file name denoting non-existent file
+;; invalid-file ....... invalid file name
+;;
+;; ($input-test INPUT PROGRAM) ... evaluates PROGRAM with current
+;; input port initialized for reading from a temporary file
+;; prepared according to INPUT. If INPUT is a string,
+;; the contents of the file is the contents of the string.
+;; Otherwise, empty file is prepared.
+;;
+
+($define! temp-file "/tmp/klisp-ports-test.txt")
+($define! test-input-file "tests/ports.k")
+($define! nonexistent-file "nonexistent-file.txt")
+($define! invalid-file "!@#$%^&*/invalid/file/name.txt")
+
+($define! prepare-input
+ ($lambda (text)
+ (with-output-to-file temp-file
+ ($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 buf)
+ (list->string (cdr buf)))))
+
+($define! eval-with-input
+ ($lambda (program denv)
+ (with-input-from-file temp-file ($lambda () (eval program denv)))))
+
+($define! eval-with-output
+ ($lambda (program denv)
+ (with-output-to-file temp-file ($lambda () (eval program denv)))))
+
+($define! $input-test
+ ($vau (input program) denv
+ (prepare-input input)
+ (eval-with-input program denv)))
+
+($define! $output-test
+ ($vau (program) denv
+ (eval-with-output program denv)
+ (with-input-from-file temp-file read-string-until-eof)))
+
+;; 15.1.1 port?
+
+($check-predicate (port? (get-current-input-port) (get-current-output-port)))
+($check-predicate (port?))
+($check-not-predicate (port? 0))
+($check-not-predicate (port? #t))
+($check-not-predicate (port? ()))
+($check-not-predicate (port? #inert))
+
+;; 15.1.2 input-port? output-port?
+
+($check-predicate (input-port? (get-current-input-port)))
+($check-predicate (input-port?))
+($check-predicate (output-port? (get-current-output-port)))
+($check-predicate (output-port?))
+
+;; 15.1.3 with-input-from-file, with-output-to-file
+;;
+;; klisp documentation:
+;;
+;; The result of the applicatives with-input-from-file
+;; and with-output-from-file is inert.
+;;
+;; R5RS:
+;;
+;; With-input-from-file and with-output-to-file
+;; return(s) the value(s) yielded by thunk.
+;;
+
+($check equal? (with-input-from-file test-input-file ($lambda () 1)) 1)
+($check-error (with-input-from-file nonexistent-file ($lambda () 1)))
+($check-error (with-input-from-file invalid-file ($lambda () 1)))
+
+($check equal? (with-output-to-file temp-file ($lambda () 1)) 1)
+($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)
+
+($check equal?
+ ($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
+
+;; 15.1.5 open-input-file open-output-file
+;; 15.1.6 close-input-file close-output-file
+
+($let ((p (open-input-file test-input-file)))
+ ($check-predicate (port? p))
+ ($check-predicate (input-port? p))
+ ($check-not-predicate (equal? p (get-current-input-port)))
+ ($check-not-predicate (equal? p (get-current-output-port)))
+ (close-input-file p))
+
+($let ((p (open-output-file temp-file)))
+ ($check-predicate (port? p))
+ ($check-predicate (output-port? p))
+ ($check-not-predicate (equal? p (get-current-input-port)))
+ ($check-not-predicate (equal? p (get-current-output-port)))
+ (close-output-file p))
+
+;; 15.1.7 read
+
+($check-predicate (eof-object? ($input-test #inert (read))))
+($check-predicate (eof-object? ($input-test "" (read))))
+
+($check equal? ($input-test "#inert" (read)) #inert)
+($check equal? ($input-test "(0 1 -1 #t #f #inert)" (read)) (list 0 1 -1 #t #f #inert))
+($check equal? ($input-test "(1 2 (3 4 5) (6 . 7))" (read)) (list 1 2 (list 3 4 5) (list* 6 7)))
+
+($check equal? ($input-test "1 2" (read)) 1)
+($check equal? ($input-test "1 2" ($sequence (read) (read))) 2)
+($check-predicate (eof-object? ($input-test "1 2" ($sequence (read) (read) (read)))))
+
+;; 15.1.8 write
+
+($check equal? ($output-test #inert) "")
+($check equal? ($output-test (write 123)) "123")
+($check equal? ($output-test (write (list 1 2 #t #f #inert ()))) "(1 2 #t #f #inert ())")
+($check equal? ($output-test (write (list 1 2 (list 3 4 5) (list* 6 7)))) "(1 2 (3 4 5) (6 . 7))")
+
+;; 15.2.1 call-with-input-file call-with-output-file
+;; 15.2.2 load
+;; 15.2.3 get-module
+;; TODO
+
+;; Additional input functions: read-char peek-char
+
+($check-predicate (eof-object? ($input-test "" (read-char))))
+($check-predicate (eof-object? ($input-test "" (peek-char))))
+
+($check equal? ($input-test "a" (read-char)) #\a)
+($check-predicate (eof-object? ($input-test "a" ($sequence (read-char) (read-char)))))
+($check equal? ($input-test "a" (peek-char)) #\a)
+($check equal? ($input-test "a" ($sequence (peek-char) (peek-char))) #\a)
+($check equal? ($input-test "a" ($sequence (peek-char) (peek-char) (peek-char))) #\a)
+($check equal? ($input-test "ab" ($sequence (read-char) (read-char))) #\b)
+($check equal? ($input-test "ab" ($sequence (peek-char) (read-char))) #\a)
+
+;; Additional input functions: char-ready?
+;; TODO
+
+;; Additional output functions: write-char newline display
+
+($check equal? ($output-test (write-char #\a)) "a")
+($check equal? ($output-test (newline)) (list->string (list #\newline)))
+($check equal? ($output-test (display "abc")) "abc")
+
diff --git a/src/tests/test-all.k b/src/tests/test-all.k
@@ -14,5 +14,7 @@
(load "tests/environments.k")
(load "tests/environment-mutation.k")
(load "tests/combiners.k")
+(load "tests/numbers.k")
+(load "tests/ports.k")
-(check-report)
-\ No newline at end of file
+(check-report)
