picrin/lib.c

/**
 * See Copyright Notice in picrin.h
 */

#include "picrin.h"
#include "picrin/lib.h"
#include "picrin/pair.h"
#include "picrin/macro.h"
#include "picrin/error.h"
#include "picrin/dict.h"
#include "picrin/string.h"
#include "picrin/proc.h"

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

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

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

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

  return lib;
}

void
pic_in_library(pic_state *pic, pic_value spec)
{
  struct pic_lib *lib;

  lib = pic_find_library(pic, spec);
  if (! lib) {
    pic_errorf(pic, "library not found: ~a", spec);
  }
  pic->lib = lib;
}

struct pic_lib *
pic_find_library(pic_state *pic, pic_value spec)
{
  pic_value v;

  v = pic_assoc(pic, spec, pic->libs, NULL);
  if (pic_false_p(v)) {
    return NULL;
  }
  return pic_lib_ptr(pic_cdr(pic, v));
}

static struct pic_dict *
import_table(pic_state *pic, pic_value spec)
{
  const pic_sym sONLY = pic_intern_cstr(pic, "only");
  const pic_sym sRENAME = pic_intern_cstr(pic, "rename");
  const pic_sym sPREFIX = pic_intern_cstr(pic, "prefix");
  const pic_sym sEXCEPT = pic_intern_cstr(pic, "except");
  struct pic_lib *lib;
  struct pic_dict *imports, *dict;
  pic_value val, id;
  pic_sym sym;
  xh_iter it;

  imports = pic_dict_new(pic);

  if (pic_list_p(spec)) {
    if (pic_eq_p(pic_car(pic, spec), pic_sym_value(sONLY))) {
      dict = import_table(pic, pic_cadr(pic, spec));
      pic_for_each (val, pic_cddr(pic, spec)) {
        pic_dict_set(pic, imports, pic_sym(val), pic_dict_ref(pic, dict, pic_sym(val)));
      }
      return imports;
    }
    if (pic_eq_p(pic_car(pic, spec), pic_sym_value(sRENAME))) {
      imports = import_table(pic, pic_cadr(pic, spec));
      pic_for_each (val, pic_cddr(pic, spec)) {
        id = pic_dict_ref(pic, imports, pic_sym(pic_car(pic, val)));
        pic_dict_del(pic, imports, pic_sym(pic_car(pic, val)));
        pic_dict_set(pic, imports, pic_sym(pic_cadr(pic, val)), id);
      }
      return imports;
    }
    if (pic_eq_p(pic_car(pic, spec), pic_sym_value(sPREFIX))) {
      dict = import_table(pic, pic_cadr(pic, spec));
      xh_begin(&it, &dict->hash);
      while (xh_next(&it)) {
        id = pic_sym_value(xh_key(it.e, pic_sym));
        val = pic_list_ref(pic, spec, 2);
        sym = pic_intern_str(pic, pic_format(pic, "~s~s", val, id));
        pic_dict_set(pic, imports, sym, xh_val(it.e, pic_value));
      }
      return imports;
    }
    if (pic_eq_p(pic_car(pic, spec), pic_sym_value(sEXCEPT))) {
      imports = import_table(pic, pic_cadr(pic, spec));
      pic_for_each (val, pic_cddr(pic, spec)) {
        pic_dict_del(pic, imports, pic_sym(val));
      }
      return imports;
    }
  }
  lib = pic_find_library(pic, spec);
  if (! lib) {
    pic_errorf(pic, "library not found: ~a", spec);
  }
  xh_begin(&it, &lib->exports);
  while (xh_next(&it)) {
    pic_dict_set(pic, imports, xh_key(it.e, pic_sym), pic_sym_value(xh_val(it.e, pic_sym)));
  }
  return imports;
}

static void
import(pic_state *pic, pic_value spec)
{
  struct pic_dict *imports;
  xh_iter it;

  pic_try {
    imports = import_table(pic, spec);
  }
  pic_catch {
    pic_errorf(pic, "syntax error around import statement: ~s", spec);
  }

  xh_begin(&it, &imports->hash);
  while (xh_next(&it)) {

#if DEBUG
    printf("* importing %s as %s\n", pic_symbol_name(pic, xh_key(it.e, pic_sym)), pic_symbol_name(pic, pic_sym(xh_val(it.e, pic_value))));
#endif

    pic_put_rename(pic, pic->lib->env, xh_key(it.e, pic_sym), pic_sym(xh_val(it.e, pic_value)));
  }
}

static void
export(pic_state *pic, pic_value spec)
{
  const pic_sym sRENAME = pic_intern_cstr(pic, "rename");
  pic_value a, b;
  pic_sym rename;

  if (pic_sym_p(spec)) {        /* (export a) */
    a = b = spec;
  } else {                      /* (export (rename a b)) */
    if (! pic_list_p(spec))
      goto fail;
    if (! pic_length(pic, spec) == 3)
      goto fail;
    if (! pic_eq_p(pic_car(pic, spec), pic_sym_value(sRENAME)))
      goto fail;
    if (! pic_sym_p(a = pic_list_ref(pic, spec, 1)))
      goto fail;
    if (! pic_sym_p(b = pic_list_ref(pic, spec, 2)))
      goto fail;
  }

  if (! pic_find_rename(pic, pic->lib->env, pic_sym(a), &rename)) {
    pic_errorf(pic, "export: symbol not defined %s", pic_symbol_name(pic, pic_sym(a)));
  }

#if DEBUG
  printf("* exporting %s as %s\n", pic_symbol_name(pic, pic_sym(b)), pic_symbol_name(pic, rename));
#endif

  xh_put_int(&pic->lib->exports, pic_sym(b), &rename);

  return;

 fail:
  pic_errorf(pic, "illegal export spec: ~s", spec);
}

void
pic_import(pic_state *pic, pic_value spec)
{
  import(pic, spec);
}

void
pic_export(pic_state *pic, pic_sym sym)
{
  export(pic, pic_sym_value(sym));
}

static bool
condexpand(pic_state *pic, pic_value clause)
{
  const pic_sym sELSE = pic_intern_cstr(pic, "else");
  const pic_sym sLIBRARY = pic_intern_cstr(pic, "library");
  const pic_sym sOR = pic_intern_cstr(pic, "or");
  const pic_sym sAND = pic_intern_cstr(pic, "and");
  const pic_sym sNOT = pic_intern_cstr(pic, "not");
  pic_sym tag;
  pic_value c, feature;

  if (pic_eq_p(clause, pic_sym_value(sELSE))) {
    return true;
  }
  if (pic_sym_p(clause)) {
    pic_for_each (feature, pic->features) {
      if(pic_eq_p(feature, clause))
        return true;
    }
    return false;
  }

  if (! (pic_pair_p(clause) && pic_sym_p(pic_car(pic, clause)))) {
    pic_errorf(pic, "invalid 'cond-expand' clause ~s", clause);
  } else {
    tag = pic_sym(pic_car(pic, clause));
  }

  if (tag == sLIBRARY) {
    return pic_find_library(pic, pic_list_ref(pic, clause, 1)) != NULL;
  }
  if (tag == sNOT) {
    return ! condexpand(pic, pic_list_ref(pic, clause, 1));
  }
  if (tag == sAND) {
    pic_for_each (c, pic_cdr(pic, clause)) {
      if (! condexpand(pic, c))
        return false;
    }
    return true;
  }
  if (tag == sOR) {
    pic_for_each (c, pic_cdr(pic, clause)) {
      if (condexpand(pic, c))
        return true;
    }
    return false;
  }

  pic_errorf(pic, "unknown 'cond-expand' directive ~s", clause);
}

static pic_value
pic_lib_condexpand(pic_state *pic)
{
  pic_value *clauses;
  size_t argc, i;

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

  for (i = 0; i < argc; i++) {
    if (condexpand(pic, pic_car(pic, clauses[i]))) {
      return pic_cons(pic, pic_sym_value(pic->rBEGIN), pic_cdr(pic, clauses[i]));
    }
  }

  return pic_none_value();
}

static pic_value
pic_lib_import(pic_state *pic)
{
  size_t argc, i;
  pic_value *argv;

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

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

  return pic_none_value();
}

static pic_value
pic_lib_export(pic_state *pic)
{
  size_t argc, i;
  pic_value *argv;

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

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

  return pic_none_value();
}

static pic_value
pic_lib_define_library(pic_state *pic)
{
  struct pic_lib *prev = pic->lib;
  size_t argc, i;
  pic_value spec, *argv;

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

  pic_open_library(pic, spec);

  pic_try {
    pic_in_library(pic, spec);

    for (i = 0; i < argc; ++i) {
      pic_void(pic_eval(pic, argv[i], pic->lib));
    }

    pic_in_library(pic, prev->name);
  }
  pic_catch {
    pic_in_library(pic, prev->name); /* restores pic->lib even if an error occurs */
    pic_throw_error(pic, pic->err);
  }

  return pic_none_value();
}

static pic_value
pic_lib_in_library(pic_state *pic)
{
  pic_value spec;

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

  pic_in_library(pic, spec);

  return pic_none_value();
}

void
pic_init_lib(pic_state *pic)
{
  void pic_defmacro(pic_state *, pic_sym, pic_sym, pic_func_t);

  pic_defmacro(pic, pic->sCOND_EXPAND, pic->rCOND_EXPAND, pic_lib_condexpand);
  pic_defmacro(pic, pic->sIMPORT, pic->rIMPORT, pic_lib_import);
  pic_defmacro(pic, pic->sEXPORT, pic->rEXPORT, pic_lib_export);
  pic_defmacro(pic, pic->sDEFINE_LIBRARY, pic->rDEFINE_LIBRARY, pic_lib_define_library);
  pic_defmacro(pic, pic->sIN_LIBRARY, pic->rIN_LIBRARY, pic_lib_in_library);
}