From db38f1360002104e3913cc9912608dbababb2fdb Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Mon, 28 Jul 2014 11:37:46 +0900 Subject: [PATCH 01/14] add main.scm --- tools/main.scm | 89 ++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 89 insertions(+) create mode 100644 tools/main.scm diff --git a/tools/main.scm b/tools/main.scm new file mode 100644 index 00000000..0fa5bc0f --- /dev/null +++ b/tools/main.scm @@ -0,0 +1,89 @@ +(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))) + +(define-library (picrin repl) + (import (scheme base) + (scheme read) + (scheme file) + (scheme write) + (scheme eval) + (scheme process-context)) + + (define (file->string file) + (with-input-from-file file + (lambda () + (let loop ((line (read-line))) + (if (eof-object? line) + "" + (string-append line (loop (read-line)))))))) + + (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 show this help\n")) + + (define (getopt) + (let ((args (cdr (command-line)))) + (if (null? args) + #f + (case (car args) + (("-h") + (print-help) + (exit 0)) + (("-e") + (cadr args)) + (else + (file->string (car args))))))) + + (define (print obj) + (write obj) + (newline)) + + (define (main-loop) + (display "> ") + (let ((expr (read))) + (if (eof-object? expr) + (begin + (newline) + (exit 0)) + (begin + (call/cc + (lambda (leave) + (with-exception-handler + (lambda (condition) + (display (error-object-message condition)) + (newline) + (leave)) + (lambda () + (print (eval expr '(picrin user))))))) + (main-loop))))) + + (define (repl) + (let ((program (getopt))) + (parameterize + ((current-input-port + (if program + (current-input-port) + (open-input-string program)))) + (main-loop)))) + + (export repl)) + +(import (picrin repl)) + +(repl) + From fc388f8d46a961df1ca540c17eb7efd942743236 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Mon, 28 Jul 2014 11:43:52 +0900 Subject: [PATCH 02/14] call main.scm inside main.c --- tools/main.c | 303 +-------------------------------------------------- 1 file changed, 5 insertions(+), 298 deletions(-) diff --git a/tools/main.c b/tools/main.c index e5129daf..dc342d82 100644 --- a/tools/main.c +++ b/tools/main.c @@ -2,284 +2,9 @@ * 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) { @@ -287,32 +12,14 @@ main(int argc, char *argv[], char **envp) pic = pic_open(argc, argv, envp); - parse_opt(argc, argv); - - if (mode == INTERACTIVE_MODE || mode == ONE_LINER_MODE) { - import_repllib(pic); + pic_try { + pic_load(pic, "/Users/yuichi/workspace/picrin/tools/main.scm"); } - - 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); } pic_close(pic); -#if DEBUG - puts("* picrin successfully closed"); -#endif - - return exit_status; + return 0; } From 786cf9d8943c3d57ab95cc6aa34a208ef61233bc Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Mon, 28 Jul 2014 11:44:19 +0900 Subject: [PATCH 03/14] fix main.scm --- tools/main.scm | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/tools/main.scm b/tools/main.scm index 0fa5bc0f..09354973 100644 --- a/tools/main.scm +++ b/tools/main.scm @@ -77,8 +77,8 @@ (parameterize ((current-input-port (if program - (current-input-port) - (open-input-string program)))) + (open-input-string program) + (current-input-port)))) (main-loop)))) (export repl)) From dd52dee01c6ca385543913c05708344ffd436f71 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Mon, 28 Jul 2014 13:22:24 +0900 Subject: [PATCH 04/14] no exit --- tools/main.scm | 4 +--- 1 file changed, 1 insertion(+), 3 deletions(-) diff --git a/tools/main.scm b/tools/main.scm index 09354973..7d1637e0 100644 --- a/tools/main.scm +++ b/tools/main.scm @@ -57,9 +57,7 @@ (display "> ") (let ((expr (read))) (if (eof-object? expr) - (begin - (newline) - (exit 0)) + (newline) ; exit (begin (call/cc (lambda (leave) From 2f7a51c096056812675445f7d889ce3e7f8e7cb7 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Tue, 29 Jul 2014 15:23:40 +0900 Subject: [PATCH 05/14] move the repl source to under piclib --- piclib/CMakeLists.txt | 3 +++ tools/main.scm => piclib/picrin/repl.scm | 18 ------------------ piclib/picrin/user.scm | 14 ++++++++++++++ tools/main.c | 3 ++- 4 files changed, 19 insertions(+), 19 deletions(-) rename tools/main.scm => piclib/picrin/repl.scm (83%) create mode 100644 piclib/picrin/user.scm 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/tools/main.scm b/piclib/picrin/repl.scm similarity index 83% rename from tools/main.scm rename to piclib/picrin/repl.scm index 7d1637e0..32c6f20b 100644 --- a/tools/main.scm +++ b/piclib/picrin/repl.scm @@ -1,16 +1,3 @@ -(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))) - (define-library (picrin repl) (import (scheme base) (scheme read) @@ -80,8 +67,3 @@ (main-loop)))) (export repl)) - -(import (picrin repl)) - -(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/tools/main.c b/tools/main.c index dc342d82..e241a277 100644 --- a/tools/main.c +++ b/tools/main.c @@ -13,7 +13,8 @@ main(int argc, char *argv[], char **envp) pic = pic_open(argc, argv, envp); pic_try { - pic_load(pic, "/Users/yuichi/workspace/picrin/tools/main.scm"); + pic_import(pic, pic_read_cstr(pic, "(picrin repl)")); + pic_funcall(pic, "repl", pic_nil_value()); } pic_catch { pic_print_backtrace(pic, pic->err); From ea0ebf5126ffcbd2d49b573531a0ad301ee750ec Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Tue, 29 Jul 2014 15:31:24 +0900 Subject: [PATCH 06/14] [bugfix] command-line returned reversed list of command line arguments --- src/system.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) 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 From f09a27cd0a0cadf714f26b14c8f5e964117dd2f0 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Tue, 29 Jul 2014 15:42:35 +0900 Subject: [PATCH 07/14] [bugfix] case doesn't compare string equality --- piclib/picrin/repl.scm | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/piclib/picrin/repl.scm b/piclib/picrin/repl.scm index 32c6f20b..f41ce090 100644 --- a/piclib/picrin/repl.scm +++ b/piclib/picrin/repl.scm @@ -21,17 +21,17 @@ (display "\n") (display "Options:\n") (display " -e [program] run one liner script\n") - (display " -h show this help\n")) + (display " -h or --help show this help\n")) (define (getopt) (let ((args (cdr (command-line)))) (if (null? args) #f - (case (car args) - (("-h") + (case (string->symbol (car args)) + ((-h --help) (print-help) (exit 0)) - (("-e") + ((-e) (cadr args)) (else (file->string (car args))))))) From 96f8a969e07935f653168fdeaf334b240e1e8f5b Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Tue, 29 Jul 2014 15:42:52 +0900 Subject: [PATCH 08/14] print takes an optional argument for output port, and returns obj itself --- piclib/picrin/repl.scm | 9 +++++---- 1 file changed, 5 insertions(+), 4 deletions(-) diff --git a/piclib/picrin/repl.scm b/piclib/picrin/repl.scm index f41ce090..6a90e54b 100644 --- a/piclib/picrin/repl.scm +++ b/piclib/picrin/repl.scm @@ -14,6 +14,11 @@ "" (string-append line (loop (read-line)))))))) + (define (print obj . port) + (write obj (if (null? port) (current-output-port) (car port))) + (newline) + obj) + (define (print-help) (display "picrin scheme\n") (display "\n") @@ -36,10 +41,6 @@ (else (file->string (car args))))))) - (define (print obj) - (write obj) - (newline)) - (define (main-loop) (display "> ") (let ((expr (read))) From 36f4a8fa66a3e1ce4626a8661202b4290d4f0dec Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Tue, 29 Jul 2014 15:43:43 +0900 Subject: [PATCH 09/14] support file execution --- piclib/picrin/repl.scm | 30 +++++++++++++++++------------- 1 file changed, 17 insertions(+), 13 deletions(-) diff --git a/piclib/picrin/repl.scm b/piclib/picrin/repl.scm index 6a90e54b..76ee5028 100644 --- a/piclib/picrin/repl.scm +++ b/piclib/picrin/repl.scm @@ -41,30 +41,34 @@ (else (file->string (car args))))))) - (define (main-loop) - (display "> ") - (let ((expr (read))) + (define (main-loop in out) + (display "> " out) + (let ((expr (read in))) (if (eof-object? expr) - (newline) ; exit + (newline out) ; exit (begin (call/cc (lambda (leave) (with-exception-handler (lambda (condition) - (display (error-object-message condition)) + (display (error-object-message condition) (current-error-port)) (newline) (leave)) (lambda () - (print (eval expr '(picrin user))))))) - (main-loop))))) + (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))) - (parameterize - ((current-input-port - (if program - (open-input-string program) - (current-input-port)))) - (main-loop)))) + (run-repl program))) (export repl)) From 9b95c3c75ec01b427a20f7486a7bee5625291534 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Tue, 29 Jul 2014 15:43:59 +0900 Subject: [PATCH 10/14] exit status --- tools/main.c | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/tools/main.c b/tools/main.c index e241a277..428b2764 100644 --- a/tools/main.c +++ b/tools/main.c @@ -9,6 +9,7 @@ int main(int argc, char *argv[], char **envp) { pic_state *pic; + int status = 0; pic = pic_open(argc, argv, envp); @@ -18,9 +19,10 @@ main(int argc, char *argv[], char **envp) } pic_catch { pic_print_backtrace(pic, pic->err); + status = 1; } pic_close(pic); - return 0; + return status; } From a15ec868bafabdcf2737821160d3bbfe7eac2996 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Tue, 29 Jul 2014 15:44:22 +0900 Subject: [PATCH 11/14] -h option should return exit status 1 --- piclib/picrin/repl.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/piclib/picrin/repl.scm b/piclib/picrin/repl.scm index 76ee5028..0d3669c7 100644 --- a/piclib/picrin/repl.scm +++ b/piclib/picrin/repl.scm @@ -35,7 +35,7 @@ (case (string->symbol (car args)) ((-h --help) (print-help) - (exit 0)) + (exit 1)) ((-e) (cadr args)) (else From 1a891036f2302bc09eeb1796c7599b683da2017c Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Tue, 29 Jul 2014 15:56:50 +0900 Subject: [PATCH 12/14] [bugfix] print should print a newline to given port --- piclib/picrin/repl.scm | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/piclib/picrin/repl.scm b/piclib/picrin/repl.scm index 0d3669c7..b07ea07d 100644 --- a/piclib/picrin/repl.scm +++ b/piclib/picrin/repl.scm @@ -15,9 +15,10 @@ (string-append line (loop (read-line)))))))) (define (print obj . port) - (write obj (if (null? port) (current-output-port) (car port))) - (newline) - obj) + (let ((port (if (null? port) (current-output-port) (car port)))) + (write obj port) + (newline port) + obj)) (define (print-help) (display "picrin scheme\n") From 48b5d6b57819fb6f6caf045584801ae9f7430427 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Tue, 29 Jul 2014 15:57:26 +0900 Subject: [PATCH 13/14] [bugfix] interleave newline --- piclib/picrin/repl.scm | 12 +++++++++--- 1 file changed, 9 insertions(+), 3 deletions(-) diff --git a/piclib/picrin/repl.scm b/piclib/picrin/repl.scm index b07ea07d..7a7c9569 100644 --- a/piclib/picrin/repl.scm +++ b/piclib/picrin/repl.scm @@ -6,13 +6,19 @@ (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))) + (let loop ((line (read-line)) (acc '())) (if (eof-object? line) - "" - (string-append line (loop (read-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)))) From 83ba9af7aabfde2334f50ec4e5850c5e657d7a8c Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Tue, 29 Jul 2014 16:01:12 +0900 Subject: [PATCH 14/14] comment out an assertion --- src/error.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) 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;