klisp

an open source interpreter for the Kernel Programming Language.
git clone http://git.hanabi.in/repos/klisp.git
Log | Files | Refs | README

klisp.c (23979B)


      1 /*
      2 ** klisp.c
      3 ** Kernel stand-alone interpreter
      4 ** See Copyright Notice in klisp.h
      5 */
      6 
      7 /*
      8 ** TODO This needs a serious clean up, I hacked it together during
      9 ** an all nighter...
     10 **
     11 ** For starters:
     12 ** - Split dofile in dofile & dostdin
     13 ** - Merge dofile and dorfile with a boolean flag (load/require)
     14 **   (use dorfile as a model)
     15 ** - Add get_ground_binding somewhere (probably kstate) and use it.
     16 */
     17 
     18 #include <stdio.h>
     19 #include <string.h>
     20 #include <stdlib.h>
     21 #include <assert.h>
     22 
     23 #include <setjmp.h>
     24 
     25 #include "klimits.h"
     26 
     27 #include "klisp.h"
     28 #include "kstate.h"
     29 #include "kauxlib.h"
     30 
     31 #include "kstring.h"
     32 #include "kcontinuation.h"
     33 #include "koperative.h"
     34 #include "kapplicative.h"
     35 #include "ksymbol.h"
     36 #include "kenvironment.h"
     37 #include "kport.h"
     38 #include "kread.h"
     39 #include "kwrite.h"
     40 #include "kerror.h"
     41 #include "krepl.h"
     42 #include "ksystem.h"
     43 #include "kghelpers.h" /* for do_pass_value and do_seq, mark_root & mark_error */
     44 
     45 static const char *progname = KLISP_PROGNAME;
     46 
     47 /* 
     48 ** Three possible status after an evaluation:
     49 ** error: the error continuation was passed a value -> EXIT_FAILURE
     50 ** root: the root continuation was passed a value -> status depends on value
     51 ** continue: normally completed evaluation, continue with next argument 
     52 */
     53 #define STATUS_ERROR -1
     54 #define STATUS_CONTINUE 0
     55 #define STATUS_ROOT 1
     56 
     57 static void print_usage (void) 
     58 {
     59     fprintf(stderr,
     60             "usage: %s [options] [script [args]].\n"
     61             "Available options are:\n"
     62             "  -e exp  eval string " KLISP_QL("exp") "\n"
     63             "  -l name  load file " KLISP_QL("name") "\n"
     64             "  -r name  require file " KLISP_QL("name") "\n"
     65             "  -i          enter interactive mode after executing " 
     66             KLISP_QL("script") "\n"
     67             "  -v          show version information\n"
     68             "  --          stop handling options\n"
     69             "  -           execute stdin and stop handling options\n"
     70             ,
     71             progname);
     72     fflush(stderr);
     73 }
     74 
     75 static void k_message (const char *pname, const char *msg) 
     76 {
     77     if (pname)
     78         fprintf(stderr, "%s: ", pname);
     79     fprintf(stderr, "%s\n", msg);
     80     fflush(stderr);
     81 }
     82 
     83 /* TODO move this to a common place to use it from elsewhere 
     84    (like the repl) */
     85 static void show_error(klisp_State *K, TValue obj) {
     86     /* FOR NOW used only for irritant list */
     87     TValue port = kcdr(G(K)->kd_error_port_key);
     88     klisp_assert(ttisfport(port) && kfport_file(port) == stderr);
     89 
     90     /* TEMP: obj should be an error obj */
     91     if (ttiserror(obj)) {
     92         Error *err_obj = tv2error(obj);
     93         TValue who = err_obj->who;
     94         char *who_str;
     95         /* TEMP? */
     96         if (ttiscontinuation(who))
     97             who = tv2cont(who)->comb;
     98 
     99         if (ttisstring(who)) {
    100             who_str = kstring_buf(who);
    101 #if KTRACK_NAMES
    102         } else if (khas_name(who)) {
    103             TValue name = kget_name(K, who);
    104             who_str = ksymbol_buf(name);
    105 #endif
    106         } else {
    107             who_str = "?";
    108         }
    109         char *msg = kstring_buf(err_obj->msg);
    110         fprintf(stderr, "\n*ERROR*: \n");
    111         fprintf(stderr, "%s: %s", who_str, msg);
    112 
    113         krooted_tvs_push(K, obj);
    114 
    115         /* Msg + irritants */
    116         /* TODO move to a new function */
    117         if (!ttisnil(err_obj->irritants)) {
    118             fprintf(stderr, ": ");
    119             kwrite_display_to_port(K, port, err_obj->irritants, false);
    120         }
    121         kwrite_newline_to_port(K, port);
    122 
    123 #if KTRACK_NAMES
    124 #if KTRACK_SI
    125         /* Location */
    126         /* TODO move to a new function */
    127         /* MAYBE: remove */
    128         if (khas_name(who) || khas_si(who)) {
    129             fprintf(stderr, "Location: ");
    130             kwrite_display_to_port(K, port, who, false);
    131             kwrite_newline_to_port(K, port);
    132         }
    133 
    134         /* Backtrace */
    135         /* TODO move to a new function */
    136         TValue tv_cont = err_obj->cont;
    137         fprintf(stderr, "Backtrace: \n");
    138         while(ttiscontinuation(tv_cont)) {
    139             kwrite_display_to_port(K, port, tv_cont, false);
    140             kwrite_newline_to_port(K, port);
    141             Continuation *cont = tv2cont(tv_cont);
    142             tv_cont = cont->parent;
    143         }
    144         /* add extra newline at the end */
    145         kwrite_newline_to_port(K, port);
    146 #endif
    147 #endif
    148         krooted_tvs_pop(K);
    149     } else {
    150         fprintf(stderr, "\n*ERROR*: not an error object passed to " 
    151                 "error continuation");
    152     }
    153     fflush(stderr);
    154 }
    155 
    156 static int report (klisp_State *K, int status) 
    157 {
    158     if (status == STATUS_ERROR) {
    159         const char *msg = "Error!";
    160         k_message(progname, msg);
    161         show_error(K, K->next_value);
    162     }
    163     return status;
    164 }
    165 
    166 static void print_version(void) 
    167 {
    168     printf("%s\n", KLISP_RELEASE "  " KLISP_COPYRIGHT);
    169 }
    170 
    171 static int dostring (klisp_State *K, const char *s, const char *name) 
    172 {
    173     klisp_lock(K);
    174 
    175     bool errorp = false; /* may be set to true in error handler */
    176     bool rootp = true; /* may be set to false in continuation */
    177 
    178     UNUSED(name); /* could use as filename?? */
    179 
    180     /* create the guard set error flag after errors */
    181     TValue exit_int = kmake_operative(K, do_int_mark_error, 
    182                                       1, p2tv(&errorp));
    183     krooted_tvs_push(K, exit_int);
    184     TValue exit_guard = kcons(K, G(K)->error_cont, exit_int);
    185     krooted_tvs_pop(K); /* already in guard */
    186     krooted_tvs_push(K, exit_guard);
    187     TValue exit_guards = kcons(K, exit_guard, KNIL);
    188     krooted_tvs_pop(K); /* already in guards */
    189     krooted_tvs_push(K, exit_guards);
    190 
    191     TValue entry_guards = KNIL;
    192 
    193     /* this is needed for interception code */
    194     TValue env = kmake_empty_environment(K);
    195     krooted_tvs_push(K, env);
    196     TValue outer_cont = kmake_continuation(K, G(K)->root_cont, 
    197                                            do_pass_value, 2, entry_guards, env);
    198     kset_outer_cont(outer_cont);
    199     krooted_tvs_push(K, outer_cont);
    200     TValue inner_cont = kmake_continuation(K, outer_cont, 
    201                                            do_pass_value, 2, exit_guards, env);
    202     kset_inner_cont(inner_cont);
    203     krooted_tvs_pop(K); krooted_tvs_pop(K); krooted_tvs_pop(K);
    204 
    205     krooted_tvs_push(K, inner_cont);
    206 
    207     /* This continuation will discard the result of the evaluation
    208        and return #inert instead, it will also signal via rootp = false
    209        that the evaluation didn't explicitly invoke the root continuation
    210     */
    211     TValue discard_cont = kmake_continuation(K, inner_cont, do_int_mark_root,
    212                                              1, p2tv(&rootp));
    213 
    214     krooted_tvs_pop(K); /* pop inner cont */
    215     krooted_tvs_push(K, discard_cont);
    216 
    217     kset_cc(K, discard_cont);
    218     krooted_tvs_pop(K); /* pop discard cont */
    219     
    220     /* create a string input port */
    221     TValue str = kstring_new_b(K, s);
    222     krooted_tvs_push(K, str);
    223 
    224     /* prepare params (str still in the gc stack) */
    225     env = K->next_env; /* this will be ignored anyways */
    226     TValue ptree = klist(K, 2, str, env);
    227     krooted_tvs_pop(K);
    228     krooted_tvs_push(K, ptree);
    229     /* TODO factor this out into a get_ground_binding(K, char *) */
    230     TValue ev = ksymbol_new_b(K, "eval-string", KNIL);
    231     krooted_vars_push(K, &ev);
    232     klisp_assert(kbinds(K, G(K)->ground_env, ev));
    233     ev = kunwrap(kget_binding(K, G(K)->ground_env, ev));
    234     krooted_vars_pop(K);
    235     krooted_tvs_pop(K);
    236 
    237     klispT_tail_call_si(K, ev, ptree, env, KNIL);
    238 
    239     klisp_unlock(K);
    240     /* LOCK: run while acquire the GIL again */
    241     klispT_run(K);
    242 
    243     int status = errorp? STATUS_ERROR : 
    244         (rootp? STATUS_ROOT : STATUS_CONTINUE);
    245     /* get the standard environment again in K->next_env */
    246     K->next_env = env;
    247     return report(K, status);
    248 }
    249 
    250 void do_file_eval(klisp_State *K)
    251 {
    252     TValue *xparams = K->next_xparams;
    253     TValue obj = K->next_value;
    254     klisp_assert(ttisnil(K->next_env));
    255     /* 
    256     ** xparams[0]: dynamic environment
    257     */
    258     TValue denv = xparams[0];
    259     TValue ls = obj;
    260     if (!ttisnil(ls)) {
    261         TValue new_cont = kmake_continuation(K, kget_cc(K), do_seq, 2, ls, denv);
    262         kset_cc(K, new_cont);
    263     } 
    264     kapply_cc(K, KINERT);
    265 }
    266 
    267 void do_file_read(klisp_State *K)
    268 {
    269     TValue *xparams = K->next_xparams;
    270     TValue obj = K->next_value;
    271     klisp_assert(ttisnil(K->next_env));
    272     UNUSED(obj);
    273     TValue port = xparams[0];
    274     /* read all file as a list (as immutable data) */
    275     TValue ls = kread_list_from_port(K, port, false);
    276 
    277     /* all ok, just one exp read (or none and obj1 is eof) */
    278     kapply_cc(K, ls);
    279 }
    280 
    281 /* name = NULL means use stdin */
    282 static int dofile(klisp_State *K, const char *name) 
    283 {
    284     klisp_lock(K);
    285     bool errorp = false; /* may be set to true in error handler */
    286     bool rootp = true; /* may be set to false in continuation */
    287 
    288     /* create a file input port (unless it's stdin, then just use) */
    289     TValue port;
    290 
    291     /* XXX better do this in a continuation */
    292     if (name == NULL) {
    293         port = kcdr(G(K)->kd_in_port_key);
    294     } else {
    295         FILE *file = fopen(name, "r");
    296         if (file == NULL) {
    297             TValue mode_str = kstring_new_b(K, "r");
    298             krooted_tvs_push(K, mode_str);
    299             TValue name_str = kstring_new_b(K, name);
    300             krooted_tvs_push(K, mode_str);
    301             TValue error_obj = klispE_new_simple_with_errno_irritants
    302                 (K, "fopen", 2, name_str, mode_str);
    303             krooted_tvs_pop(K);
    304             krooted_tvs_pop(K);
    305             K->next_value = error_obj;
    306             return report(K, STATUS_ERROR);
    307         }
    308 	    
    309         TValue name_str = kstring_new_b(K, name);
    310         krooted_tvs_push(K, name_str);
    311         port = kmake_std_fport(K, name_str, false, false, file);
    312         krooted_tvs_pop(K);
    313     }
    314     
    315     krooted_tvs_push(K, port);
    316     /* TODO this is exactly the same as in string, factor the code out */
    317     /* create the guard set error flag after errors */
    318     TValue exit_int = kmake_operative(K, do_int_mark_error, 
    319                                       1, p2tv(&errorp));
    320     krooted_tvs_push(K, exit_int);
    321     TValue exit_guard = kcons(K, G(K)->error_cont, exit_int);
    322     krooted_tvs_pop(K); /* already in guard */
    323     krooted_tvs_push(K, exit_guard);
    324     TValue exit_guards = kcons(K, exit_guard, KNIL);
    325     krooted_tvs_pop(K); /* already in guards */
    326     krooted_tvs_push(K, exit_guards);
    327 
    328     TValue entry_guards = KNIL;
    329 
    330     /* this is needed for interception code */
    331     TValue env = kmake_empty_environment(K);
    332     krooted_tvs_push(K, env);
    333     TValue outer_cont = kmake_continuation(K, G(K)->root_cont, 
    334                                            do_pass_value, 2, entry_guards, env);
    335     kset_outer_cont(outer_cont);
    336     krooted_tvs_push(K, outer_cont);
    337     TValue inner_cont = kmake_continuation(K, outer_cont, 
    338                                            do_pass_value, 2, exit_guards, env);
    339     kset_inner_cont(inner_cont);
    340     krooted_tvs_pop(K); krooted_tvs_pop(K); krooted_tvs_pop(K);
    341 
    342     /* only port remains in the root stack */
    343     krooted_tvs_push(K, inner_cont);
    344 
    345 
    346     /* This continuation will discard the result of the evaluation
    347        and return #inert instead, it will also signal via rootp = false
    348        that the evaluation didn't explicitly invoke the root continuation
    349     */
    350     TValue discard_cont = kmake_continuation(K, inner_cont, do_int_mark_root,
    351                                              1, p2tv(&rootp));
    352 
    353     krooted_tvs_pop(K); /* pop inner cont */
    354     krooted_tvs_push(K, discard_cont);
    355 
    356     /* XXX This should probably be an extra param to the function */
    357     env = K->next_env; /* this is the standard env that should be used for 
    358                           evaluation */
    359     TValue eval_cont = kmake_continuation(K, discard_cont, do_file_eval, 
    360                                           1, env);
    361     krooted_tvs_pop(K); /* pop discard cont */
    362     krooted_tvs_push(K, eval_cont);
    363     TValue read_cont = kmake_continuation(K, eval_cont, do_file_read, 
    364                                           1, port);
    365     krooted_tvs_pop(K); /* pop eval cont */
    366     krooted_tvs_pop(K); /* pop port */
    367     kset_cc(K, read_cont); /* this will protect all conts from gc */
    368     klispT_apply_cc(K, KINERT);
    369 
    370     klisp_unlock(K);
    371     /* LOCK: run while acquire the GIL again */
    372     klispT_run(K);
    373 
    374     int status = errorp? STATUS_ERROR : 
    375         (rootp? STATUS_ROOT : STATUS_CONTINUE);
    376 
    377     /* get the standard environment again in K->next_env */
    378     K->next_env = env;
    379     return report(K, status);
    380 }
    381 
    382 static void dotty(klisp_State *K)
    383 {
    384     klisp_lock(K);
    385     TValue env = K->next_env;
    386     kinit_repl(K);
    387     klisp_unlock(K);
    388     /* LOCK: run while acquire the GIL again */
    389     klispT_run(K);
    390     /* get the standard environment again in K->next_env */
    391     K->next_env = env;
    392 }
    393 
    394 /* name != NULL */
    395 static int dorfile(klisp_State *K, const char *name) 
    396 {
    397     klisp_lock(K);
    398     bool errorp = false; /* may be set to true in error handler */
    399     bool rootp = true; /* may be set to false in continuation */
    400 
    401     klisp_assert(name != NULL);
    402 
    403     TValue name_str = kstring_new_b(K, name);
    404     krooted_tvs_push(K, name_str);
    405     /* TODO this is exactly the same as in string, factor the code out */
    406     /* create the guard set error flag after errors */
    407     TValue exit_int = kmake_operative(K, do_int_mark_error, 
    408                                       1, p2tv(&errorp));
    409     krooted_tvs_push(K, exit_int);
    410     TValue exit_guard = kcons(K, G(K)->error_cont, exit_int);
    411     krooted_tvs_pop(K); /* already in guard */
    412     krooted_tvs_push(K, exit_guard);
    413     TValue exit_guards = kcons(K, exit_guard, KNIL);
    414     krooted_tvs_pop(K); /* already in guards */
    415     krooted_tvs_push(K, exit_guards);
    416 
    417     TValue entry_guards = KNIL;
    418 
    419     /* this is needed for interception code */
    420     TValue env = kmake_empty_environment(K);
    421     krooted_tvs_push(K, env);
    422     TValue outer_cont = kmake_continuation(K, G(K)->root_cont, 
    423                                            do_pass_value, 2, entry_guards, env);
    424     kset_outer_cont(outer_cont);
    425     krooted_tvs_push(K, outer_cont);
    426     TValue inner_cont = kmake_continuation(K, outer_cont, 
    427                                            do_pass_value, 2, exit_guards, env);
    428     kset_inner_cont(inner_cont);
    429     krooted_tvs_pop(K); krooted_tvs_pop(K); krooted_tvs_pop(K);
    430 
    431     /* only name remains in the root stack */
    432     krooted_tvs_push(K, inner_cont);
    433 
    434 
    435     /* This continuation will discard the result of the evaluation
    436        and return #inert instead, it will also signal via rootp = false
    437        that the evaluation didn't explicitly invoke the root continuation
    438     */
    439     /* XXX for now, GC protect the environment in this discard continuation */
    440     /* TODO use a more elegant way! */
    441     TValue discard_cont = kmake_continuation(K, inner_cont, do_int_mark_root,
    442                                              2, p2tv(&rootp), K->next_env);
    443     krooted_tvs_pop(K); /* pop inner cont */
    444 
    445     /* set the cont & call require */
    446     kset_cc(K, discard_cont); 
    447     
    448     /* prepare params (str still in the gc stack) */
    449     env = K->next_env; /* this will be ignored anyways */
    450     TValue ptree = kcons(K, name_str, KNIL);
    451     krooted_tvs_pop(K);
    452     krooted_tvs_push(K, ptree);
    453     /* TODO factor this out into a get_ground_binding(K, char *) */
    454     TValue req = ksymbol_new_b(K, "require", KNIL);
    455     krooted_vars_push(K, &req);
    456     klisp_assert(kbinds(K, G(K)->ground_env, req));
    457     req = kunwrap(kget_binding(K, G(K)->ground_env, req));
    458     krooted_tvs_pop(K);
    459     krooted_vars_pop(K);
    460 
    461     klispT_tail_call_si(K, req, ptree, env, KNIL);
    462     klisp_unlock(K);
    463     /* LOCK: run while acquire the GIL again */
    464     klispT_run(K);
    465 
    466     int status = errorp? STATUS_ERROR : 
    467         (rootp? STATUS_ROOT : STATUS_CONTINUE);
    468 
    469     /* get the standard environment again in K->next_env */
    470     K->next_env = env;
    471     return report(K, status);
    472 }
    473 
    474 static int handle_script(klisp_State *K, char **argv, int n) 
    475 {
    476     const char *fname;
    477     /* XXX/TODO save arguments to script */
    478 //    int narg = getargs(L, argv, n);  /* collect arguments */
    479 //    lua_setglobal(L, "arg");
    480     fname = argv[n];
    481     if (strcmp(fname, "-") == 0 && strcmp(argv[n-1], "--") != 0) 
    482         fname = NULL;  /* stdin */
    483 
    484     return dofile(K, fname);
    485 }
    486 
    487 /* check that argument has no extra characters at the end */
    488 #define notail(x)	{if ((x)[2] != '\0') return -1;}
    489 
    490 static int collectargs (char **argv, bool *pi, bool *pv, bool *pe, bool *pl)
    491 {
    492     int i;
    493     for (i = 1; argv[i] != NULL; i++) {
    494         if (argv[i][0] != '-')  /* not an option? */
    495             return i;
    496         switch (argv[i][1]) {  /* option */
    497         case '-':
    498             notail(argv[i]);
    499             return (argv[i+1] != NULL ? i+1 : 0);
    500         case '\0':
    501             return i;
    502         case 'i':
    503             notail(argv[i]);
    504             *pi = true;  /* go through */
    505         case 'v':
    506             notail(argv[i]);
    507             *pv = true;
    508             break;
    509         case 'e':
    510             *pe = true;  
    511             goto select_arg;
    512         case 'l': 
    513             *pl = true;
    514             goto select_arg;
    515         case 'r':
    516         select_arg:
    517             if (argv[i][2] == '\0') {
    518                 i++;
    519                 if (argv[i] == NULL)
    520                     return -1;
    521             }
    522             break;
    523         default: 
    524             return -1;  /* invalid option */
    525         }
    526     }
    527     return 0;
    528 }
    529 
    530 static int runargs (klisp_State *K, char **argv, int n) 
    531 {
    532     /* There is a standard env in K->next_env, a common one is used for all 
    533        evaluations (init, expression args, script/repl) */
    534     TValue env = K->next_env; 
    535     UNUSED(env);
    536 
    537     /* TEMP All passes to root cont and all resulting values will be ignored,
    538        the only way to interrupt the running of arguments is to throw an error */
    539     for (int i = 1; i < n; i++) {
    540         if (argv[i] == NULL) 
    541             continue;
    542 
    543         klisp_assert(argv[i][0] == '-');
    544 
    545         switch (argv[i][1]) {  /* option */
    546         case 'e': { /* eval expr */
    547             const char *chunk = argv[i] + 2;
    548             if (*chunk == '\0') 
    549                 chunk = argv[++i];
    550             klisp_assert(chunk != NULL);
    551 
    552             int res = dostring(K, chunk, "=(command line)");
    553             if (res != STATUS_CONTINUE)
    554                 return res; /* stop if eval fails/exit */
    555             break;
    556         }
    557         case 'l': { /* load file */
    558             const char *filename = argv[i] + 2;
    559             if (*filename == '\0') filename = argv[++i];
    560             klisp_assert(filename != NULL);
    561 	    
    562             int res = dofile(K, filename);
    563             if (res != STATUS_CONTINUE)
    564                 return res; /* stop if file fails/exit */
    565             break;
    566         }
    567         case 'r': { /* require file */
    568             const char *filename = argv[i] + 2;
    569             if (*filename == '\0') filename = argv[++i];
    570             klisp_assert(filename != NULL);
    571 	    
    572             int res = dorfile(K, filename);
    573             if (res != STATUS_CONTINUE)
    574                 return res; /* stop if file fails/exit */
    575             break;
    576         }
    577         default: 
    578             break;
    579         }
    580     }
    581     return STATUS_CONTINUE;
    582 }
    583 
    584 /* LOCK: assume that the GIL is acquired */
    585 static void populate_argument_lists(klisp_State *K, char **argv, int argc, 
    586                                     int script)
    587 {
    588     /* first create the script list */
    589     TValue tail = KNIL;
    590     TValue obj = KINERT;
    591     krooted_vars_push(K, &tail);
    592     krooted_vars_push(K, &obj);
    593     while(argc > script) {
    594         char *arg = argv[--argc];
    595         obj = kstring_new_b_imm(K, arg);
    596         tail = kimm_cons(K, obj, tail);
    597     }
    598     /* Store the script argument list */
    599     obj = ksymbol_new_b(K, "get-script-arguments", KNIL);
    600     klisp_assert(kbinds(K, G(K)->ground_env, obj));
    601     obj = kunwrap(kget_binding(K, G(K)->ground_env, obj));
    602     tv2op(obj)->extra[0] = tail;
    603 
    604     while(argc > 0) {
    605         char *arg = argv[--argc];
    606         obj = kstring_new_b_imm(K, arg);
    607         tail = kimm_cons(K, obj, tail);
    608     }
    609     /* Store the interpreter argument list */
    610     obj = ksymbol_new_b(K, "get-interpreter-arguments", KNIL);
    611     klisp_assert(kbinds(K, G(K)->ground_env, obj));
    612     obj = kunwrap(kget_binding(K, G(K)->ground_env, obj));
    613     tv2op(obj)->extra[0] = tail;
    614 
    615     krooted_vars_pop(K);
    616     krooted_vars_pop(K);
    617 }
    618 
    619 static int handle_klispinit(klisp_State *K) 
    620 {
    621     const char *init = getenv(KLISP_INIT);
    622     int res;
    623     if (init == NULL) 
    624         res = STATUS_CONTINUE;
    625     else 
    626         res = dostring(K, init, "=" KLISP_INIT);
    627 
    628     return res;
    629 }
    630 
    631 /* This is weird but was done to follow lua scheme */
    632 struct Smain {
    633     int argc;
    634     char **argv;
    635     int status; /* STATUS_ROOT, STATUS_ERROR, STATUS_CONTINUE */
    636 };
    637 
    638 static void pmain(klisp_State *K) 
    639 {
    640     /* This is weird but was done to follow lua scheme */
    641     struct Smain *s = (struct Smain *) pvalue(K->next_value);
    642     char **argv = s->argv;
    643     s->status = STATUS_CONTINUE;
    644     /* this is needed in case there are no arguments and no init */
    645     K->next_value = KINERT;
    646 
    647 
    648     /* There is a standard env in K->next_env, a common one is used for all 
    649        evaluations (init, expression args, script/repl) */
    650     //TValue env = K->next_env; 
    651 
    652     if (argv[0] && argv[0][0])
    653         progname = argv[0];
    654 
    655     /* TODO Here we should load libraries, however we don't have any
    656        non native bindings in the ground environment yet */
    657 
    658     /* RATIONALE I wanted to write all bindings in c, so that I can later on
    659        profile them against non native versions and see how they fare.
    660        Also by writing all in c it's easy to be consistent, especially with
    661        error messages */
    662 
    663     /* init (eval KLISP_INIT env variable contents) */
    664     s->status = handle_klispinit(K);
    665     if (s->status != STATUS_CONTINUE)
    666         return;
    667 
    668     bool has_i = false, has_v = false, has_e = false, has_l = false;
    669     int script = collectargs(argv, &has_i, &has_v, &has_e, &has_l);
    670 
    671     if (script < 0) { /* invalid args? */
    672         print_usage();
    673         s->status = STATUS_ERROR;
    674         return;
    675     }
    676 
    677     if (has_v)
    678         print_version();
    679 
    680     /* TEMP this could be either set before or after running the arguments,
    681        we'll do it before for now */
    682     klisp_lock(K);
    683     populate_argument_lists(K, argv, s->argc, (script > 0) ? script : s->argc);
    684     klisp_unlock(K);
    685     
    686     s->status = runargs(K, argv, (script > 0) ? script : s->argc);
    687 
    688     if (s->status != STATUS_CONTINUE)
    689         return;
    690 
    691     if (script > 0) {
    692         s->status = handle_script(K, argv, script);
    693     }
    694 
    695     if (s->status != STATUS_CONTINUE)
    696         return;
    697 
    698     if (has_i) { 
    699         dotty(K);
    700     } else if (script == 0 && !has_e && !has_l && !has_v) {
    701         if (ksystem_isatty(K, kcurr_input_port(K))) {
    702             print_version();
    703             dotty(K);
    704         } else {
    705             s->status = dofile(K, NULL);
    706         }
    707     }
    708 }
    709 
    710 int main(int argc, char *argv[]) 
    711 {
    712     struct Smain s;
    713     klisp_State *K = klispL_newstate();
    714 
    715     if (K == NULL) {
    716         k_message(argv[0], "cannot create state: not enough memory");
    717         return EXIT_FAILURE;
    718     }
    719 
    720     /* Set the main thread as the current thread */
    721     /* XXX/TEMP this could be made in run... */
    722     K->thread = pthread_self();
    723 
    724     /* This is weird but was done to follow lua scheme */
    725     s.argc = argc;
    726     s.argv = argv;
    727     K->next_value = p2tv(&s);
    728 
    729     pmain(K);
    730 
    731     /* convert s.status to either EXIT_SUCCESS or EXIT_FAILURE */
    732     if (s.status == STATUS_CONTINUE || s.status == STATUS_ROOT) {
    733         /* must check value passed to the root continuation to
    734            return proper exit status */
    735         if (ttisinert(K->next_value)) {
    736             s.status = EXIT_SUCCESS;
    737         } else if (ttisboolean(K->next_value)) {
    738             s.status = kis_true(K->next_value)? EXIT_SUCCESS : EXIT_FAILURE;
    739         } else if (ttisfixint(K->next_value)) {
    740             s.status = ivalue(K->next_value);
    741         } else {
    742             s.status = EXIT_FAILURE;
    743         }
    744     } else { /* s.status == STATUS_ERROR */
    745         s.status = EXIT_FAILURE;
    746     }
    747 
    748     klisp_close(K);
    749 
    750     return s.status;
    751 }