some procedures are moved to contrib/

system related procedures are moved to contrib/

file related procedures are moved to contrib/

load related procedures are moved to conrib/

contrib/03.file/CMakeLists.txt

@@ -0,0 +1,4 @@
+file(GLOB PICRIN_FILE_SOURCES ${PROJECT_SOURCE_DIR}/contrib/03.file/src/*.c)
+
+list(APPEND PICRIN_CONTRIB_INITS file)
+list(APPEND PICRIN_CONTRIB_SOURCES ${PICRIN_FILE_SOURCES})

contrib/03.file/src/file.c

@@ -0,0 +1,119 @@
+/**
+ * See Copyright Notice in picrin.h
+ */
+
+#include "picrin.h"
+#include "picrin/port.h"
+#include "picrin/error.h"
+
+pic_noreturn static void
+file_error(pic_state *pic, const char *msg)
+{
+  pic_throw(pic, pic->sFILE, msg, pic_nil_value());
+}
+
+static pic_value
+generic_open_file(pic_state *pic, const char *fname, char *mode, short flags)
+{
+  struct pic_port *port;
+  xFILE *file;
+
+  file = xfopen(fname, mode);
+  if (! file) {
+    file_error(pic, "could not open file");
+  }
+
+  port = (struct pic_port *)pic_obj_alloc(pic, sizeof(struct pic_port), PIC_TT_PORT);
+  port->file = file;
+  port->flags = flags;
+  port->status = PIC_PORT_OPEN;
+
+  return pic_obj_value(port);
+}
+
+pic_value
+pic_file_open_input_file(pic_state *pic)
+{
+  static const short flags = PIC_PORT_IN | PIC_PORT_TEXT;
+  char *fname;
+
+  pic_get_args(pic, "z", &fname);
+
+  return generic_open_file(pic, fname, "r", flags);
+}
+
+pic_value
+pic_file_open_binary_input_file(pic_state *pic)
+{
+  static const short flags = PIC_PORT_IN | PIC_PORT_BINARY;
+  char *fname;
+
+  pic_get_args(pic, "z", &fname);
+
+  return generic_open_file(pic, fname, "rb", flags);
+}
+
+pic_value
+pic_file_open_output_file(pic_state *pic)
+{
+  static const short flags = PIC_PORT_OUT | PIC_PORT_TEXT;
+  char *fname;
+
+  pic_get_args(pic, "z", &fname);
+
+  return generic_open_file(pic, fname, "w", flags);
+}
+
+pic_value
+pic_file_open_binary_output_file(pic_state *pic)
+{
+  static const short flags = PIC_PORT_OUT | PIC_PORT_BINARY;
+  char *fname;
+
+  pic_get_args(pic, "z", &fname);
+
+  return generic_open_file(pic, fname, "wb", flags);
+}
+
+pic_value
+pic_file_exists_p(pic_state *pic)
+{
+  char *fname;
+  FILE *fp;
+
+  pic_get_args(pic, "z", &fname);
+
+  fp = fopen(fname, "r");
+  if (fp) {
+    fclose(fp);
+    return pic_true_value();
+  } else {
+    return pic_false_value();
+  }
+}
+
+pic_value
+pic_file_delete(pic_state *pic)
+{
+  char *fname;
+
+  pic_get_args(pic, "z", &fname);
+
+  if (remove(fname) != 0) {
+    file_error(pic, "file cannot be deleted");
+  }
+  return pic_none_value();
+}
+
+void
+pic_init_file(pic_state *pic)
+{
+  pic_deflibrary (pic, "(scheme file)") {
+    pic_defun(pic, "open-input-file", pic_file_open_input_file);
+    pic_defun(pic, "open-binary-input-file", pic_file_open_binary_input_file);
+    pic_defun(pic, "open-output-file", pic_file_open_output_file);
+    pic_defun(pic, "open-binary-output-file", pic_file_open_binary_output_file);
+    pic_defun(pic, "file-exists?", pic_file_exists_p);
+    pic_defun(pic, "delete-file", pic_file_delete);
+  }
+}

contrib/03.load/CMakeLists.txt

@@ -0,0 +1,4 @@
+file(GLOB PICRIN_LOAD_SOURCES ${PROJECT_SOURCE_DIR}/contrib/03.load/src/*.c)
+
+list(APPEND PICRIN_CONTRIB_INITS load)
+list(APPEND PICRIN_CONTRIB_SOURCES ${PICRIN_LOAD_SOURCES})

contrib/03.load/src/load.c

@@ -0,0 +1,50 @@
+/**
+ * See Copyright Notice in picrin.h
+ */
+
+#include "picrin.h"
+#include "picrin/pair.h"
+#include "picrin/port.h"
+#include "picrin/error.h"
+
+void
+pic_load(pic_state *pic, const char *filename)
+{
+  struct pic_port *port;
+  xFILE *file;
+
+  file = xfopen(filename, "r");
+  if (file == NULL) {
+    pic_errorf(pic, "could not open file: %s", filename);
+  }
+
+  port = (struct pic_port *)pic_obj_alloc(pic, sizeof(struct pic_port), PIC_TT_PORT);
+  port->file = file;
+  port->flags = PIC_PORT_IN | PIC_PORT_TEXT;
+  port->status = PIC_PORT_OPEN;
+
+  pic_load_port(pic, port);
+
+  pic_close_port(pic, port);
+}
+
+static pic_value
+pic_load_load(pic_state *pic)
+{
+  pic_value envid;
+  char *fn;
+
+  pic_get_args(pic, "z|o", &fn, &envid);
+
+  pic_load(pic, fn);
+
+  return pic_none_value();
+}
+
+void
+pic_init_load(pic_state *pic)
+{
+  pic_deflibrary (pic, "(scheme load)") {
+    pic_defun(pic, "load", pic_load_load);
+  }
+}

contrib/03.system/CMakeLists.txt

@@ -0,0 +1,4 @@
+file(GLOB PICRIN_SYSTEM_SOURCES ${PROJECT_SOURCE_DIR}/contrib/03.system/src/*.c)
+
+list(APPEND PICRIN_CONTRIB_INITS system)
+list(APPEND PICRIN_CONTRIB_SOURCES ${PICRIN_SYSTEM_SOURCES})

contrib/03.system/src/system.c

@@ -0,0 +1,136 @@
+/**
+ * See Copyright Notice in picrin.h
+ */
+
+#include <stdlib.h>
+
+#include "picrin.h"
+#include "picrin/string.h"
+#include "picrin/pair.h"
+#include "picrin/cont.h"
+
+static pic_value
+pic_system_cmdline(pic_state *pic)
+{
+  pic_value v = pic_nil_value();
+  int i;
+
+  pic_get_args(pic, "");
+
+  for (i = 0; i < pic->argc; ++i) {
+    size_t ai = pic_gc_arena_preserve(pic);
+
+    v = pic_cons(pic, pic_obj_value(pic_make_str_cstr(pic, pic->argv[i])), v);
+    pic_gc_arena_restore(pic, ai);
+  }
+
+  return pic_reverse(pic, v);
+}
+
+static pic_value
+pic_system_exit(pic_state *pic)
+{
+  pic_value v;
+  int argc, status = EXIT_SUCCESS;
+
+  argc = pic_get_args(pic, "|o", &v);
+  if (argc == 1) {
+    switch (pic_type(v)) {
+    case PIC_TT_FLOAT:
+      status = (int)pic_float(v);
+      break;
+    case PIC_TT_INT:
+      status = pic_int(v);
+      break;
+    default:
+      break;
+    }
+  }
+
+  pic_close(pic);
+
+  exit(status);
+}
+
+static pic_value
+pic_system_emergency_exit(pic_state *pic)
+{
+  pic_value v;
+  int argc, status = EXIT_FAILURE;
+
+  argc = pic_get_args(pic, "|o", &v);
+  if (argc == 1) {
+    switch (pic_type(v)) {
+    case PIC_TT_FLOAT:
+      status = (int)pic_float(v);
+      break;
+    case PIC_TT_INT:
+      status = pic_int(v);
+      break;
+    default:
+      break;
+    }
+  }
+
+  _Exit(status);
+}
+
+static pic_value
+pic_system_getenv(pic_state *pic)
+{
+  char *str, *val;
+
+  pic_get_args(pic, "z", &str);
+
+  val = getenv(str);
+
+  if (val == NULL)
+    return pic_nil_value();
+  else
+    return pic_obj_value(pic_make_str_cstr(pic, val));
+}
+
+static pic_value
+pic_system_getenvs(pic_state *pic)
+{
+  char **envp;
+  pic_value data = pic_nil_value();
+  size_t ai = pic_gc_arena_preserve(pic);
+
+  pic_get_args(pic, "");
+
+  if (! pic->envp) {
+    return pic_nil_value();
+  }
+
+  for (envp = pic->envp; *envp; ++envp) {
+    pic_str *key, *val;
+    size_t i;
+
+    for (i = 0; (*envp)[i] != '='; ++i)
+      ;
+
+    key = pic_make_str(pic, *envp, i);
+    val = pic_make_str_cstr(pic, getenv(pic_str_cstr(key)));
+
+    /* push */
+    data = pic_acons(pic, pic_obj_value(key), pic_obj_value(val), data);
+
+    pic_gc_arena_restore(pic, ai);
+    pic_gc_protect(pic, data);
+  }
+
+  return data;
+}
+
+void
+pic_init_system(pic_state *pic)
+{
+  pic_deflibrary (pic, "(scheme process-context)") {
+    pic_defun(pic, "command-line", pic_system_cmdline);
+    pic_defun(pic, "exit", pic_system_exit);
+    pic_defun(pic, "emergency-exit", pic_system_emergency_exit);
+    pic_defun(pic, "get-environment-variable", pic_system_getenv);
+    pic_defun(pic, "get-environment-variables", pic_system_getenvs);
+  }
+}

contrib/03.time/CMakeLists.txt

@@ -0,0 +1,4 @@
+file(GLOB PICRIN_TIME_SOURCES ${PROJECT_SOURCE_DIR}/contrib/03.time/src/*.c)
+
+list(APPEND PICRIN_CONTRIB_INITS time)
+list(APPEND PICRIN_CONTRIB_SOURCES ${PICRIN_TIME_SOURCES})

contrib/03.time/src/time.c

@@ -0,0 +1,49 @@
+/**
+ * See Copyright Notice in picrin.h
+ */
+
+#include <time.h>
+
+#include "picrin.h"
+
+#define UTC_TAI_DIFF 35
+
+static pic_value
+pic_current_second(pic_state *pic)
+{
+  time_t t;
+
+  pic_get_args(pic, "");
+
+  time(&t);
+  return pic_float_value((double)t + UTC_TAI_DIFF);
+}
+
+static pic_value
+pic_current_jiffy(pic_state *pic)
+{
+  clock_t c;
+
+  pic_get_args(pic, "");
+
+  c = clock();
+  return pic_int_value((int)c); /* The year 2038 problem :-| */
+}
+
+static pic_value
+pic_jiffies_per_second(pic_state *pic)
+{
+  pic_get_args(pic, "");
+
+  return pic_int_value(CLOCKS_PER_SEC);
+}
+
+void
+pic_init_time(pic_state *pic)
+{
+  pic_deflibrary (pic, "(scheme time)") {
+    pic_defun(pic, "current-second", pic_current_second);
+    pic_defun(pic, "current-jiffy", pic_current_jiffy);
+    pic_defun(pic, "jiffies-per-second", pic_jiffies_per_second);
+  }
+}

contrib/05.r7rs/scheme/base.scm

@@ -3,7 +3,8 @@
           (picrin macro)
           (picrin record)
           (picrin syntax-rules)
-          (picrin string))
+          (picrin string)
+          (scheme file))
 
   ;; 4.1.2. Literal expressions