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 }