commit 7cfeb32417607210301aad01b7b31f5b294a9fa2
parent cbeffb8e1ebdd3b53491b728477ae9d08bf2ac44
Author: Andres Navarro <canavarro82@gmail.com>
Date: Sun, 20 Nov 2011 20:41:43 -0300
Some refactoring in preparation for the new improved standalone interpreter.
Diffstat:
9 files changed, 134 insertions(+), 27 deletions(-)
diff --git a/src/kerror.c b/src/kerror.c
@@ -102,7 +102,8 @@ void klispE_throw_with_irritants(klisp_State *K, char *msg, TValue irritants)
kcall_cont(K, K->error_cont, error_obj);
}
-void klispE_throw_system_error_with_irritants(klisp_State *K, const char *service, int errnum, TValue irritants)
+void klispE_throw_system_error_with_irritants(
+ klisp_State *K, const char *service, int errnum, TValue irritants)
{
TValue error_description = klispE_describe_errno(K, service, errnum);
krooted_tvs_push(K, error_description);
@@ -190,7 +191,8 @@ static const char * const symbolic_error_codes[] = {
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]);
+ int tabsize = sizeof(symbolic_error_codes) /
+ sizeof(symbolic_error_codes[0]);
if (0 <= errnum && errnum < tabsize)
code = symbolic_error_codes[errnum];
if (code == NULL)
diff --git a/src/kgcontinuations.c b/src/kgcontinuations.c
@@ -344,11 +344,13 @@ void kinit_continuations_ground_env(klisp_State *K)
add_applicative(K, ground_env, "continuation->applicative",
continuation_applicative, 0);
/* 7.2.6 root-continuation */
+ klisp_assert(ttiscontinuation(K->root_cont));
add_value(K, ground_env, "root-continuation",
K->root_cont);
/* 7.2.7 error-continuation */
+ klisp_assert(ttiscontinuation(K->error_cont));
add_value(K, ground_env, "error-continuation",
- K->root_cont);
+ K->error_cont);
/* 7.3.1 apply-continuation */
add_applicative(K, ground_env, "apply-continuation", apply_continuation,
0);
diff --git a/src/kgerror.c b/src/kgerror.c
@@ -4,7 +4,6 @@
** See Copyright Notice in klisp.h
*/
-#include <assert.h>
#include <stdbool.h>
#include <stdint.h>
@@ -36,7 +35,7 @@ void error_object_message(klisp_State *K, TValue *xparams, TValue ptree,
UNUSED(denv);
bind_1tp(K, ptree, "error object", ttiserror, error_tv);
Error *err_obj = tv2error(error_tv);
- assert(ttisstring(err_obj->msg));
+ klisp_assert(ttisstring(err_obj->msg));
kapply_cc(K, err_obj->msg);
}
@@ -49,7 +48,7 @@ void error_object_irritants(klisp_State *K, TValue *xparams, TValue ptree,
Error *err_obj = tv2error(error_tv);
kapply_cc(K, err_obj->irritants);
}
-
+/* REFACTOR this is the same as do_pass_value */
void do_exception_cont(klisp_State *K, TValue *xparams, TValue obj)
{
UNUSED(xparams);
@@ -57,17 +56,15 @@ void do_exception_cont(klisp_State *K, TValue *xparams, TValue obj)
kapply_cc(K, obj);
}
+/* REFACTOR maybe this should be in kerror.c */
/* Create system-error-continuation. */
void kinit_error_hierarchy(klisp_State *K)
{
- assert(ttiscontinuation(K->error_cont));
- assert(ttisinert(K->system_error_cont));
+ klisp_assert(ttiscontinuation(K->error_cont));
+ klisp_assert(ttisinert(K->system_error_cont));
- K->system_error_cont = kmake_continuation(K, K->error_cont, do_exception_cont, 0);
- TValue symbol = ksymbol_new(K, "system-error-continuation", KNIL);
- krooted_tvs_push(K, symbol);
- kadd_binding(K, K->ground_env, symbol, K->system_error_cont);
- krooted_tvs_pop(K);
+ K->system_error_cont = kmake_continuation(K, K->error_cont,
+ do_exception_cont, 0);
}
/* init ground */
@@ -80,4 +77,7 @@ void kinit_error_ground_env(klisp_State *K)
add_applicative(K, ground_env, "error", r7rs_error, 0);
add_applicative(K, ground_env, "error-object-message", error_object_message, 0);
add_applicative(K, ground_env, "error-object-irritants", error_object_irritants, 0);
+
+ klisp_assert(ttiscontinuation(K->system_error_cont));
+ add_value(K, ground_env, "system-error-continuation", K->system_error_cont);
}
diff --git a/src/kgnumbers.c b/src/kgnumbers.c
@@ -2351,4 +2351,6 @@ void kinit_numbers_ground_env(klisp_State *K)
add_applicative(K, ground_env, "sqrt", ksqrt, 0);
/* 12.9.6 expt */
add_applicative(K, ground_env, "expt", kexpt, 0);
+
+ /* TODO add some conversion like number->string, string->number */
}
diff --git a/src/kgpairs_lists.c b/src/kgpairs_lists.c
@@ -1101,4 +1101,6 @@ void kinit_pairs_lists_ground_env(klisp_State *K)
add_applicative(K, ground_env, "countable-list?", countable_listp, 0);
/* 6.3.10 reduce */
add_applicative(K, ground_env, "reduce", reduce, 0);
+
+ /* TODO add make-list, list-copy and reverse (from r7rs) */
}
diff --git a/src/klisp.c b/src/klisp.c
@@ -17,20 +17,80 @@
#include "kauxlib.h"
#include "kscript.h"
+/* TODO this should be moved to a file named like klispconf.h (see lua) */
+/*
+@@ 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.
+*/
+#define KLISP_QL(x) "'" x "'"
+#define KLISP_QS KLISP_QL("%s")
+/* /TODO */
+
+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 require library " 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\n", msg);
+ fflush(stderr);
+}
+
+struct Smain {
+ int argc;
+ char **argv;
+ int status;
+};
+
int main(int argc, char *argv[])
{
- 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;
+ if (argv[0] && argv[0][0])
+ progname = argv[0];
+
+ klisp_State *K = klispL_newstate();
+
+ if (K == NULL) {
+ k_message(argv[0], "cannot create state: not enough memory");
+ return EXIT_FAILURE;
}
+
+ /* TODO Here we should load libraries, however we don't have any
+ non native bindings in the ground environment yet */
+ /* RATIONALE I wanted to write all bindings in c, so that I can later on
+ profile them against non native versions and see how they fare.
+ Also by writing all in c it's easy to be consistent, especially with
+ error messages */
+
+ /* XXX Fix REPL, Fix Script */
+
+ // klispS_run(K); /* XXX Now this does nothing */
+ int exit_code = EXIT_FAILURE; // K->script_exit_code;
+ klisp_close(K);
+
+ /* TEMP */
+ print_usage();
+
+ return exit_code;
}
diff --git a/src/krepl.c b/src/krepl.c
@@ -43,6 +43,7 @@ void do_repl_read(klisp_State *K, TValue *xparams, TValue obj)
UNUSED(obj);
/* show prompt */
+ /* TODO put this in a variable like in lua */
fprintf(stdout, "klisp> ");
TValue port = kcdr(K->kd_in_port_key);
@@ -131,7 +132,7 @@ void do_repl_error(klisp_State *K, TValue *xparams, TValue obj)
/* FOR NOW used only for irritant list */
TValue port = kcdr(K->kd_error_port_key);
- klisp_assert(kfport_file(port) == stderr);
+ klisp_assert(ttisfport(port) && kfport_file(port) == stderr);
/* TEMP: obj should be an error obj */
if (ttiserror(obj)) {
diff --git a/src/kstate.c b/src/kstate.c
@@ -38,6 +38,7 @@
#include "kbytevector.h"
#include "kgpairs_lists.h" /* for creating list_app */
+#include "kerror.h" /* for creating error hierarchy */
#include "kgc.h" /* for memory freeing & gc init */
@@ -238,6 +239,13 @@ klisp_State *klisp_newstate (klisp_Alloc f, void *ud) {
/* TODO si */
K->module_params_sym = ksymbol_new(K, "module-parameters", KNIL);
+ /* Create the root and error continuation (will be added to the
+ environment in kinit_ground_env) */
+ K->root_cont = kmake_continuation(K, KNIL, do_root_exit, 0);
+ K->error_cont = kmake_continuation(K, K->root_cont, do_error_exit, 0);
+ /* this must be done before calling kinit_ground_env */
+ kinit_error_hierarchy(K);
+
kinit_ground_env(K);
/* set the threshold for gc start now that we have allocated all mem */
@@ -247,6 +255,31 @@ klisp_State *klisp_newstate (klisp_Alloc f, void *ud) {
}
/*
+** Root and Error continuations
+*/
+void do_root_exit(klisp_State *K, TValue *xparams, TValue obj)
+{
+ UNUSED(xparams);
+
+ /* Just save the value and end the loop */
+ K->next_value = obj;
+ /* TEMP the return code is SUCCESS iff obj is inert */
+ K->script_exit_code = ttisinert(obj)? EXIT_SUCCESS : EXIT_FAILURE;
+ K->next_func = NULL; /* force the loop to terminate */
+ return;
+}
+
+void do_error_exit(klisp_State *K, TValue *xparams, TValue obj)
+{
+ UNUSED(xparams);
+ UNUSED(obj);
+
+ /* TEMP Just pass a value to the root continuation that
+ would result in an EXIT_FAILURE */
+ kapply_cc(K, KFALSE);
+}
+
+/*
** Stacks memory management
*/
diff --git a/src/kstate.h b/src/kstate.h
@@ -142,6 +142,7 @@ struct klisp_State {
bool write_displayp;
/* script */
+ /* REFACTOR rename to exit_code */
int script_exit_code;
/* auxiliary stack */
@@ -497,6 +498,10 @@ void klisp_close (klisp_State *K);
void do_interception(klisp_State *K, TValue *xparams, TValue obj);
+/* for root and error continuations */
+void do_root_exit(klisp_State *K, TValue *xparams, TValue obj);
+void do_error_exit(klisp_State *K, TValue *xparams, TValue obj);
+
/* simple accessors for dynamic keys */
/* XXX: this is ugly but we can't include kpair.h here so... */
