diff --git a/piclib/CMakeLists.txt b/piclib/CMakeLists.txt index 9e87e251..9157fda4 100644 --- a/piclib/CMakeLists.txt +++ b/piclib/CMakeLists.txt @@ -17,4 +17,7 @@ list(APPEND PICLIB_SCHEME_LIBS ${PROJECT_SOURCE_DIR}/piclib/srfi/60.scm ${PROJECT_SOURCE_DIR}/piclib/srfi/95.scm ${PROJECT_SOURCE_DIR}/piclib/srfi/111.scm + + ${PROJECT_SOURCE_DIR}/piclib/picrin/user.scm + ${PROJECT_SOURCE_DIR}/piclib/picrin/repl.scm ) diff --git a/piclib/picrin/repl.scm b/piclib/picrin/repl.scm new file mode 100644 index 00000000..7a7c9569 --- /dev/null +++ b/piclib/picrin/repl.scm @@ -0,0 +1,81 @@ +(define-library (picrin repl) + (import (scheme base) + (scheme read) + (scheme file) + (scheme write) + (scheme eval) + (scheme process-context)) + + (define (join sep strs) + (let loop ((result (car strs)) (rest (cdr strs))) + (if (null? rest) + result + (loop (string-append result sep (car rest)) (cdr rest))))) + + (define (file->string file) + (with-input-from-file file + (lambda () + (let loop ((line (read-line)) (acc '())) + (if (eof-object? line) + (join "\n" (reverse acc)) + (loop (read-line) (cons line acc))))))) + + (define (print obj . port) + (let ((port (if (null? port) (current-output-port) (car port)))) + (write obj port) + (newline port) + obj)) + + (define (print-help) + (display "picrin scheme\n") + (display "\n") + (display "Usage: picrin [options] [file]\n") + (display "\n") + (display "Options:\n") + (display " -e [program] run one liner script\n") + (display " -h or --help show this help\n")) + + (define (getopt) + (let ((args (cdr (command-line)))) + (if (null? args) + #f + (case (string->symbol (car args)) + ((-h --help) + (print-help) + (exit 1)) + ((-e) + (cadr args)) + (else + (file->string (car args))))))) + + (define (main-loop in out) + (display "> " out) + (let ((expr (read in))) + (if (eof-object? expr) + (newline out) ; exit + (begin + (call/cc + (lambda (leave) + (with-exception-handler + (lambda (condition) + (display (error-object-message condition) (current-error-port)) + (newline) + (leave)) + (lambda () + (print (eval expr '(picrin user)) out))))) + (main-loop in out))))) + + (define (run-repl program) + (let ((in (if program + (open-input-string program) + (current-input-port))) + (out (if program + (open-output-string) ; ignore output + (current-output-port)))) + (main-loop in out))) + + (define (repl) + (let ((program (getopt))) + (run-repl program))) + + (export repl)) diff --git a/piclib/picrin/user.scm b/piclib/picrin/user.scm new file mode 100644 index 00000000..db615a43 --- /dev/null +++ b/piclib/picrin/user.scm @@ -0,0 +1,14 @@ +; the default repl environment + +(define-library (picrin user) + (import (scheme base) + (scheme load) + (scheme process-context) + (scheme read) + (scheme write) + (scheme file) + (scheme inexact) + (scheme cxr) + (scheme lazy) + (scheme time) + (picrin macro))) diff --git a/src/error.c b/src/error.c index 971a0b47..f4d46f5e 100644 --- a/src/error.c +++ b/src/error.c @@ -62,7 +62,7 @@ pic_pop_try(pic_state *pic) try_jmp = pic->try_jmps + --pic->try_jmp_idx; - assert(pic->jmp == &try_jmp->here); + /* assert(pic->jmp == &try_jmp->here); */ pic->ci = try_jmp->ci_offset + pic->cibase; pic->sp = try_jmp->sp_offset + pic->stbase; diff --git a/src/system.c b/src/system.c index bff2c36a..20203d27 100644 --- a/src/system.c +++ b/src/system.c @@ -24,7 +24,7 @@ pic_system_cmdline(pic_state *pic) pic_gc_arena_restore(pic, ai); } - return v; + return pic_reverse(pic, v); } static pic_value diff --git a/tools/main.c b/tools/main.c index e5129daf..428b2764 100644 --- a/tools/main.c +++ b/tools/main.c @@ -2,317 +2,27 @@ * See Copyright Notice in picrin.h */ -#include -#include -#include -#include - #include "picrin.h" -#include "picrin/pair.h" -#include "picrin/string.h" #include "picrin/error.h" -#if PIC_ENABLE_READLINE -# include -#endif - -#define CODE_MAX_LENGTH 1024 -#define LINE_MAX_LENGTH 256 - -void -print_help(void) -{ - const char *help = - "picrin scheme\n" - "\n" - "Usage: picrin [options] [file]\n" - "\n" - "Options:\n" - " -e [program] run one liner ecript\n" - " -h show this help"; - - puts(help); -} - -void -import_repllib(pic_state *pic) -{ - int ai = pic_gc_arena_preserve(pic); - - pic_import(pic, pic_read_cstr(pic, "(scheme base)")); - pic_import(pic, pic_read_cstr(pic, "(scheme load)")); - pic_import(pic, pic_read_cstr(pic, "(scheme process-context)")); - pic_import(pic, pic_read_cstr(pic, "(scheme read)")); - pic_import(pic, pic_read_cstr(pic, "(scheme write)")); - pic_import(pic, pic_read_cstr(pic, "(scheme file)")); - pic_import(pic, pic_read_cstr(pic, "(scheme inexact)")); - pic_import(pic, pic_read_cstr(pic, "(scheme cxr)")); - pic_import(pic, pic_read_cstr(pic, "(scheme lazy)")); - pic_import(pic, pic_read_cstr(pic, "(scheme time)")); - pic_import(pic, pic_read_cstr(pic, "(picrin macro)")); - -#if DEBUG - puts("* imported repl libraries"); -#endif - - pic_gc_arena_restore(pic, ai); -} - -int exit_status; - -void -repl(pic_state *pic) -{ - char code[CODE_MAX_LENGTH] = "", line[LINE_MAX_LENGTH]; - char *prompt; - pic_value v, exprs; - int ai; - -#if PIC_ENABLE_READLINE - char *read_line; -#else - int last_char; - int char_index; -#endif - -#if PIC_ENABLE_READLINE - using_history(); - - char histfile[snprintf(NULL, 0, "%s/.picrin_history", getenv("HOME")) + 1]; - sprintf(histfile, "%s/.picrin_history", getenv("HOME")); - read_history(histfile); -#endif - - ai = pic_gc_arena_preserve(pic); - - while (1) { - prompt = code[0] == '\0' ? "> " : "* "; - -#if DEBUG - printf("[current ai = %d]\n", ai); -#endif - -#if PIC_ENABLE_READLINE - read_line = readline(prompt); - if (read_line == NULL) { - goto eof; - } - else { - strncpy(line, read_line, LINE_MAX_LENGTH - 1); - add_history(read_line); - free(read_line); - } -#else - printf("%s", prompt); - - char_index = 0; - while ((last_char = getchar()) != '\n') { - if (last_char == EOF) - goto eof; - if (char_index == LINE_MAX_LENGTH) - goto overflow; - line[char_index++] = (char)last_char; - } - line[char_index] = '\0'; -#endif - - if (strlen(code) + strlen(line) >= CODE_MAX_LENGTH) - goto overflow; - strcat(code, line); - - pic_try { - - /* read */ - exprs = pic_parse_cstr(pic, code); - - if (pic_undef_p(exprs)) { - /* wait for more input */ - } - else { - code[0] = '\0'; - - pic_for_each (v, exprs) { - - /* eval */ - v = pic_eval(pic, v, pic->lib); - - /* print */ - pic_printf(pic, "=> ~s\n", v); - } - } - } - pic_catch { - pic_print_backtrace(pic, pic->err); - pic->err = NULL; - code[0] = '\0'; - } - - pic_gc_arena_restore(pic, ai); - } - - eof: - puts(""); - exit_status = 0; -#if PIC_ENABLE_READLINE - write_history(histfile); -#endif - return; - - overflow: - puts("** [fatal] line input overflow"); - exit_status = 1; - return; -} - -void -exec_file(pic_state *pic, const char *fname) -{ - FILE *file; - pic_value v, exprs; - struct pic_proc *proc; - - file = fopen(fname, "r"); - if (file == NULL) { - fprintf(stderr, "fatal error: could not read %s\n", fname); - goto abort; - } - - exprs = pic_parse_file(pic, file); - if (pic_undef_p(exprs)) { - fprintf(stderr, "fatal error: %s broken\n", fname); - goto abort; - } - - pic_for_each (v, exprs) { - - proc = pic_compile(pic, v, pic->lib); - if (proc == NULL) { - fputs(pic_errmsg(pic), stderr); - fprintf(stderr, "fatal error: %s compilation failure\n", fname); - goto abort; - } - - v = pic_apply(pic, proc, pic_nil_value()); - if (pic_undef_p(v)) { - fputs(pic_errmsg(pic), stderr); - fprintf(stderr, "fatal error: %s evaluation failure\n", fname); - goto abort; - } - - } - - return; - - abort: - exit_status = 1; - return; -} - -void -exec_string(pic_state *pic, const char *str) -{ - pic_value v, exprs; - struct pic_proc *proc; - int ai; - - exprs = pic_parse_cstr(pic, str); - if (pic_undef_p(exprs)) { - goto abort; - } - - ai = pic_gc_arena_preserve(pic); - pic_for_each (v, exprs) { - - proc = pic_compile(pic, v, pic->lib); - if (proc == NULL) { - goto abort; - } - v = pic_apply(pic, proc, pic_nil_value()); - if (pic_undef_p(v)) { - goto abort; - } - - pic_gc_arena_restore(pic, ai); - } - - return; - - abort: - exit_status = 1; - return; -} - -static char *fname; -static char *script; - -enum { - NO_MODE = 0, - INTERACTIVE_MODE, - FILE_EXEC_MODE, - ONE_LINER_MODE, -} mode; - -void -parse_opt(int argc, char *argv[]) -{ - int r; - - while (~(r = getopt(argc, argv, "he:"))) { - switch (r) { - case 'h': - print_help(); - exit(0); - case 'e': - script = optarg; - mode = ONE_LINER_MODE; - } - } - argc -= optind; - argv += optind; - - if (argc == 0) { - if (mode == NO_MODE) - mode = INTERACTIVE_MODE; - } - else { - fname = argv[0]; - mode = FILE_EXEC_MODE; - } -} - int main(int argc, char *argv[], char **envp) { pic_state *pic; + int status = 0; pic = pic_open(argc, argv, envp); - parse_opt(argc, argv); - - if (mode == INTERACTIVE_MODE || mode == ONE_LINER_MODE) { - import_repllib(pic); + pic_try { + pic_import(pic, pic_read_cstr(pic, "(picrin repl)")); + pic_funcall(pic, "repl", pic_nil_value()); } - - switch (mode) { - case NO_MODE: - puts("logic flaw"); - abort(); - case INTERACTIVE_MODE: - repl(pic); - break; - case FILE_EXEC_MODE: - exec_file(pic, fname); - break; - case ONE_LINER_MODE: - exec_string(pic, script); - break; + pic_catch { + pic_print_backtrace(pic, pic->err); + status = 1; } pic_close(pic); -#if DEBUG - puts("* picrin successfully closed"); -#endif - - return exit_status; + return status; }