void
pic_print_backtrace(pic_state *pic, xFILE *file)
{
  assert(! pic_invalid_p(pic->err));

  if (! pic_error_p(pic->err)) {
    xfprintf(file, "raise: ");
    pic_fwrite(pic, pic->err, file);
  } else {
    struct pic_error *e;

    e = pic_error_ptr(pic->err);
    if (e->type != pic_intern_cstr(pic, "")) {
      pic_fwrite(pic, pic_obj_value(e->type), file);
      xfprintf(file, " ");
    }
    xfprintf(file, "error: ");
    pic_fwrite(pic, pic_obj_value(e->msg), file);
    xfprintf(file, "\n");

    /* TODO: print error irritants */

    xfputs(pic_str_cstr(pic, e->stack), file);
  }
}

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

static pic_value
pic_regexp_regexp_match(pic_state *pic)
{
  pic_value reg;
  const char *input;
  regmatch_t match[100];
  pic_value matches, positions;
  pic_str *str;
  int i, offset;

  pic_get_args(pic, "oz", &reg, &input);

  pic_assert_type(pic, reg, regexp);

  matches = pic_nil_value();
  positions = pic_nil_value();

  if (strchr(pic_regexp_data_ptr(reg)->flags, 'g') != NULL) {
    /* global search */

    offset = 0;
    while (regexec(&pic_regexp_data_ptr(reg)->reg, input, 1, match, 0) != REG_NOMATCH) {
      pic_push(pic, pic_obj_value(pic_str_new(pic, input, match[0].rm_eo - match[0].rm_so)), matches);
      pic_push(pic, pic_int_value(offset), positions);

      offset += match[0].rm_eo;
      input += match[0].rm_eo;
    }
  } else {
    /* local search */

    if (regexec(&pic_regexp_data_ptr(reg)->reg, input, 100, match, 0) == 0) {
      for (i = 0; i < 100; ++i) {
        if (match[i].rm_so == -1) {
          break;
        }
        str = pic_str_new(pic, input + match[i].rm_so, match[i].rm_eo - match[i].rm_so);
        pic_push(pic, pic_obj_value(str), matches);
        pic_push(pic, pic_int_value(match[i].rm_so), positions);
      }
    }
  }

  if (pic_nil_p(matches)) {
    matches = pic_false_value();
    positions = pic_false_value();
  } else {
    matches = pic_reverse(pic, matches);
    positions = pic_reverse(pic, positions);
  }
  return pic_values2(pic, matches, positions);
}

void
pic_init_port(pic_state *pic)
{
  pic_defvar(pic, "current-input-port", pic_obj_value(pic->xSTDIN), NULL);
  pic_defvar(pic, "current-output-port", pic_obj_value(pic->xSTDOUT), NULL);
  pic_defvar(pic, "current-error-port", pic_obj_value(pic->xSTDERR), NULL);

  pic_defun(pic, "call-with-port", pic_port_call_with_port);

  pic_defun(pic, "input-port?", pic_port_input_port_p);
  pic_defun(pic, "output-port?", pic_port_output_port_p);
  pic_defun(pic, "textual-port?", pic_port_textual_port_p);
  pic_defun(pic, "binary-port?", pic_port_binary_port_p);
  pic_defun(pic, "port?", pic_port_port_p);

  pic_defun(pic, "port-open?", pic_port_port_open_p);
  pic_defun(pic, "close-port", pic_port_close_port);

  /* string I/O */
  pic_defun(pic, "open-input-string", pic_port_open_input_string);
  pic_defun(pic, "open-output-string", pic_port_open_output_string);
  pic_defun(pic, "get-output-string", pic_port_get_output_string);
  pic_defun(pic, "open-input-bytevector", pic_port_open_input_blob);
  pic_defun(pic, "open-output-bytevector", pic_port_open_output_bytevector);
  pic_defun(pic, "get-output-bytevector", pic_port_get_output_bytevector);

  /* input */
  pic_defun(pic, "read-char", pic_port_read_char);
  pic_defun(pic, "peek-char", pic_port_peek_char);
  pic_defun(pic, "read-line", pic_port_read_line);
  pic_defun(pic, "eof-object?", pic_port_eof_object_p);
  pic_defun(pic, "eof-object", pic_port_eof_object);
  pic_defun(pic, "char-ready?", pic_port_char_ready_p);
  pic_defun(pic, "read-string", pic_port_read_string);
  pic_defun(pic, "read-u8", pic_port_read_byte);
  pic_defun(pic, "peek-u8", pic_port_peek_byte);
  pic_defun(pic, "u8-ready?", pic_port_byte_ready_p);
  pic_defun(pic, "read-bytevector", pic_port_read_blob);
  pic_defun(pic, "read-bytevector!", pic_port_read_blob_ip);

  /* output */
  pic_defun(pic, "newline", pic_port_newline);
  pic_defun(pic, "write-char", pic_port_write_char);
  pic_defun(pic, "write-string", pic_port_write_string);
  pic_defun(pic, "write-u8", pic_port_write_byte);
  pic_defun(pic, "write-bytevector", pic_port_write_blob);
  pic_defun(pic, "flush-output-port", pic_port_flush);
}

static pic_value
pic_vec_vector_to_string(pic_state *pic)
{
  pic_vec *vec;
  char *buf;
  int n, start, end, i;
  pic_str *str;

  n = pic_get_args(pic, "v|ii", &vec, &start, &end);

  switch (n) {
  case 1:
    start = 0;
  case 2:
    end = vec->len;
  }

  if (end < start) {
    pic_errorf(pic, "vector->string: end index must not be less than start index");
  }

  buf = pic_malloc(pic, end - start);

  for (i = start; i < end; ++i) {
    pic_assert_type(pic, vec->data[i], char);

    buf[i - start] = pic_char(vec->data[i]);
  }

  str = pic_make_str(pic, buf, end - start);
  pic_free(pic, buf);

  return pic_obj_value(str);
}

static pic_value
pic_vec_string_to_vector(pic_state *pic)
{
  pic_str *str;
  int n, start, end, i;
  pic_vec *vec;

  n = pic_get_args(pic, "s|ii", &str, &start, &end);

  switch (n) {
  case 1:
    start = 0;
  case 2:
    end = pic_str_len(str);
  }

  if (end < start) {
    pic_errorf(pic, "string->vector: end index must not be less than start index");
  }

  vec = pic_make_vec(pic, end - start);

  for (i = 0; i < end - start; ++i) {
    vec->data[i] = pic_char_value(pic_str_ref(pic, str, i + start));
  }
  return pic_obj_value(vec);
}

static pic_value
pic_vec_vector_append(pic_state *pic)
{
  pic_value *argv;
  int argc, i, j, len;
  pic_vec *vec;

  pic_get_args(pic, "*", &argc, &argv);

  len = 0;
  for (i = 0; i < argc; ++i) {
    pic_assert_type(pic, argv[i], vec);
    len += pic_vec_ptr(argv[i])->len;
  }

  vec = pic_make_vec(pic, len);

  len = 0;
  for (i = 0; i < argc; ++i) {
    for (j = 0; j < pic_vec_ptr(argv[i])->len; ++j) {
      vec->data[len + j] = pic_vec_ptr(argv[i])->data[j];
    }
    len += pic_vec_ptr(argv[i])->len;
  }

  return pic_obj_value(vec);
}

static pic_value
pic_str_list_to_string(pic_state *pic)
{
  pic_str *str;
  pic_value list, e, it;
  int i;
  char *buf;

  pic_get_args(pic, "o", &list);

  if (pic_length(pic, list) == 0) {
    return pic_obj_value(pic_make_str(pic, NULL, 0));
  }

  buf = pic_malloc(pic, pic_length(pic, list));

  pic_try {
    i = 0;
    pic_for_each (e, list, it) {
      pic_assert_type(pic, e, char);

      buf[i++] = pic_char(e);
    }

    str = pic_make_str(pic, buf, i);
  }

static pic_value
pic_blob_bytevector(pic_state *pic)
{
  pic_value *argv;
  size_t argc, i;
  pic_blob *blob;
  unsigned char *data;

  pic_get_args(pic, "*", &argc, &argv);

  blob = pic_make_blob(pic, argc);

  data = blob->data;

  for (i = 0; i < argc; ++i) {
    pic_assert_type(pic, argv[i], int);

    if (pic_int(argv[i]) < 0 || pic_int(argv[i]) > 255) {
      pic_errorf(pic, "byte out of range");
    }

    *data++ = (unsigned char)pic_int(argv[i]);
  }

  return pic_obj_value(blob);
}

static pic_value
pic_blob_bytevector_append(pic_state *pic)
{
  size_t argc, i, j, len;
  pic_value *argv;
  pic_blob *blob;

  pic_get_args(pic, "*", &argc, &argv);

  len = 0;
  for (i = 0; i < argc; ++i) {
    pic_assert_type(pic, argv[i], blob);
    len += pic_blob_ptr(argv[i])->len;
  }

  blob = pic_make_blob(pic, len);

  len = 0;
  for (i = 0; i < argc; ++i) {
    for (j = 0; j < pic_blob_ptr(argv[i])->len; ++j) {
      blob->data[len + j] = pic_blob_ptr(argv[i])->data[j];
    }
    len += pic_blob_ptr(argv[i])->len;
  }

  return pic_obj_value(blob);
}

static pic_value
pic_blob_bytevector_copy(pic_state *pic)
{
  pic_blob *from, *to;
  int n;
  size_t start, end, i = 0;

  n = pic_get_args(pic, "b|kk", &from, &start, &end);

  switch (n) {
  case 1:
    start = 0;
  case 2:
    end = from->len;
  }

  if (end < start) {
    pic_errorf(pic, "make-bytevector: end index must not be less than start index");
  }

  to = pic_make_blob(pic, end - start);
  while (start < end) {
    to->data[i++] = from->data[start++];
  }

  return pic_obj_value(to);
}

static pic_value
pic_port_read_string(pic_state *pic){
  struct pic_port *port = pic_stdin(pic), *buf;
  pic_str *str;
  int k, i;
  int c;

  pic_get_args(pic, "i|p", &k,  &port);

  assert_port_profile(port, PIC_PORT_IN | PIC_PORT_TEXT, PIC_PORT_OPEN, "read-stritg");

  c = EOF;
  buf = pic_open_output_string(pic);
  for(i = 0; i < k; ++i) {
    if((c = xfgetc(port->file)) == EOF){
      break;
    }
    xfputc(c, buf->file);
  }

  str = pic_get_output_string(pic, buf);
  if (pic_strlen(str) == 0 && c == EOF) {
    return pic_eof_object();
  }
  else {
    return pic_obj_value(str);
  }

}

struct pic_lib *
pic_open_library(pic_state *pic, pic_value name)
{
  struct pic_lib *lib;
  struct pic_senv *senv;
  struct pic_dict *exports;

  if ((lib = pic_find_library(pic, name)) != NULL) {

#if DEBUG
    printf("* reopen library: ");
    pic_debug(pic, name);
    puts("");
#endif

    return lib;
  }

  senv = pic_null_syntactic_environment(pic);
  exports = pic_make_dict(pic);

  lib = (struct pic_lib *)pic_obj_alloc(pic, sizeof(struct pic_lib), PIC_TT_LIB);
  lib->name = name;
  lib->env = senv;
  lib->exports = exports;

  /* register! */
  pic->libs = pic_acons(pic, name, pic_obj_value(lib), pic->libs);

  return lib;
}

static pic_value
pic_vec_vector_map(pic_state *pic)
{
  struct pic_proc *proc;
  int argc, i, len, j;
  pic_value *argv, vals;
  pic_vec *vec;

  pic_get_args(pic, "l*", &proc, &argc, &argv);

  len = INT_MAX;
  for (i = 0; i < argc; ++i) {
    pic_assert_type(pic, argv[i], vec);

    len = len < pic_vec_ptr(argv[i])->len
      ? len
      : pic_vec_ptr(argv[i])->len;
  }

  vec = pic_make_vec(pic, len);

  for (i = 0; i < len; ++i) {
    vals = pic_nil_value();
    for (j = 0; j < argc; ++j) {
      pic_push(pic, pic_vec_ptr(argv[j])->data[i], vals);
    }
    vec->data[i] = pic_apply_list(pic, proc, vals);
  }

  return pic_obj_value(vec);
}

static pic_value
pic_vec_vector_copy(pic_state *pic)
{
  pic_vec *vec, *to;
  int n, start, end, i = 0;

  n = pic_get_args(pic, "v|ii", &vec, &start, &end);

  switch (n) {
  case 1:
    start = 0;
  case 2:
    end = vec->len;
  }

  if (end < start) {
    pic_errorf(pic, "vector-copy: end index must not be less than start index");
  }

  to = pic_make_vec(pic, end - start);
  while (start < end) {
    to->data[i++] = vec->data[start++];
  }

  return pic_obj_value(to);
}

pic_str *
pic_get_backtrace(pic_state *pic)
{
  size_t ai = pic_gc_arena_preserve(pic);
  pic_callinfo *ci;
  pic_str *trace;

  trace = pic_make_str(pic, NULL, 0);

  for (ci = pic->ci; ci != pic->cibase; --ci) {
    struct pic_proc *proc = pic_proc_ptr(ci->fp[0]);

    trace = pic_str_cat(pic, trace, pic_make_str_cstr(pic, "  at "));
    trace = pic_str_cat(pic, trace, pic_make_str_cstr(pic, pic_symbol_name(pic, pic_proc_name(proc))));

    if (pic_proc_func_p(proc)) {
      trace = pic_str_cat(pic, trace, pic_make_str_cstr(pic, " (native function)\n"));
    } else if (pic_proc_irep_p(proc)) {
      trace = pic_str_cat(pic, trace, pic_make_str_cstr(pic, " (unknown location)\n")); /* TODO */
    }
  }

  pic_gc_arena_restore(pic, ai);
  pic_gc_protect(pic, pic_obj_value(trace));

  return trace;
}

static pic_value
pic_reg_make_register(pic_state *pic)
{
  struct pic_reg *reg;
  struct pic_proc *proc;

  pic_get_args(pic, "");

  reg = pic_make_reg(pic);

  proc = pic_make_proc(pic, reg_call);

  pic_proc_env_set(pic, proc, "reg", pic_obj_value(reg));

  return pic_obj_value(proc);
}

static pic_value
reg_get(pic_state *pic, struct pic_reg *reg, void *key)
{
  if (! pic_reg_has(pic, reg, key)) {
    return pic_false_value();
  }
  return pic_cons(pic, pic_obj_value(key), pic_reg_ref(pic, reg, key));
}

void
pic_raise(pic_state *pic, pic_value obj)
{
  pic_value a;
  struct pic_proc *handler;

  if (pic->ridx == 0) {
    pic_abort(pic, "logic flaw: no exception handler remains");
  }

  handler = pic->rescue[--pic->ridx];
  pic_gc_protect(pic, pic_obj_value(handler));

  a = pic_apply_argv(pic, handler, 1, obj);
  /* when the handler returns */
  pic_errorf(pic, "handler returned", 2, pic_obj_value(handler), a);
}

pic_value
pic_record_ref(pic_state *pic, struct pic_record *rec, pic_sym *slot)
{
  if (! pic_dict_has(pic, rec->data, slot)) {
    pic_errorf(pic, "slot named ~s is not found for record: ~s", pic_obj_value(slot), rec);
  }
  return pic_dict_ref(pic, rec->data, slot);
}