commit 0d5eff2c98f48e483cc1326c7f47674e520f20fe
parent 12d6b247b8b03719fec82111802030ce2c8552d5
Author: Oto Havle <havleoto@gmail.com>
Date: Thu, 20 Oct 2011 14:58:26 +0200
Added noninteractive script execution. Script name can be specified as a command line argument. Additional command line arguments and exit codes are handled according to SRFI-22.
Diffstat:
7 files changed, 301 insertions(+), 12 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 \
@@ -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/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/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/kscript.c b/src/kscript.c
@@ -0,0 +1,244 @@
+/*
+** 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
+}
diff --git a/src/kscript.h b/src/kscript.h
@@ -0,0 +1,24 @@
+/*
+** krepl.h
+** klisp noninteractive script execution
+** See Copyright Notice in klisp.h
+*/
+
+#ifndef kscript_h
+#define kscript_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);
+
+/* 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) */
