conservatory
/
picrin
4
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Merge branch 'rewrite-repl-in-scheme'

This commit is contained in:
Yuichi Nishiwaki 2014-07-29 16:05:10 +09:00
parent bc0b1aa6d6 83ba9af7aa
commit c646c4e0ed
6 changed files with 108 additions and 300 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
piclib/CMakeLists.txt
View File

@ -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
)

81
piclib/picrin/repl.scm Normal file
View File

@ -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))

14
piclib/picrin/user.scm Normal file
View File

@ -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)))

2
src/error.c
View File

@ -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;

2
src/system.c
View File

@ -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

306
tools/main.c
View File

@ -2,317 +2,27 @@
* See Copyright Notice in picrin.h
*/
#include <stdio.h>
#include <stdlib.h>
#include <string.h>
#include <getopt.h>
#include "picrin.h"
#include "picrin/pair.h"
#include "picrin/string.h"
#include "picrin/error.h"
#if PIC_ENABLE_READLINE
# include <editline/readline.h>
#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;
}