Merge branch 'rewrite-repl-in-scheme'

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
   )

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

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

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;

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

tools/main.c

@@ -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);
+  pic_try {
-
+    pic_import(pic, pic_read_cstr(pic, "(picrin repl)"));
-  if (mode == INTERACTIVE_MODE || mode == ONE_LINER_MODE) {
+    pic_funcall(pic, "repl", pic_nil_value());
-    import_repllib(pic);
   }
-
+  pic_catch {
-  switch (mode) {
+    pic_print_backtrace(pic, pic->err);
-  case NO_MODE:
+    status = 1;
-    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_close(pic);
 
-#if DEBUG
+  return status;
-  puts("* picrin successfully closed");
-#endif
-
-  return exit_status;
 }