Merge branch 'reimplement-library-primitives-in-scheme'

contrib/05.r7rs/scheme/base.scm

@@ -518,4 +518,6 @@
           write-string
           write-u8
           write-bytevector
-          flush-output-port))
+          flush-output-port)
+
+  (export features))

extlib/benz/codegen.c

@@ -51,6 +51,9 @@ resolve(pic_state *pic, pic_value var, struct pic_env *env)
 static void
 define_macro(pic_state *pic, pic_sym *uid, struct pic_proc *mac)
 {
+  if (pic_dict_has(pic, pic->macros, uid)) {
+    pic_warnf(pic, "redefining syntax variable: ~s", pic_obj_value(uid));
+  }
   pic_dict_set(pic, pic->macros, uid, pic_obj_value(mac));
 }
 
@@ -209,8 +212,6 @@ expand_defmacro(pic_state *pic, pic_value expr, struct pic_env *env)
   }
   if ((uid = pic_find_variable(pic, env, var)) == NULL) {
     uid = pic_add_variable(pic, env, var);
-  } else {
-    pic_warnf(pic, "redefining syntax variable: ~s", var);
   }
 
   val = pic_cadr(pic, pic_cdr(pic, expr));

extlib/benz/include/picrin.h

@@ -233,8 +233,7 @@ struct pic_lib *pic_find_library(pic_state *, pic_value);
        ((pic->lib = pic->prev_lib),                                     \
         (pic->prev_lib = NULL)))
 
-void pic_import(pic_state *, pic_value);
+void pic_import(pic_state *, struct pic_lib *);
-void pic_import_library(pic_state *, struct pic_lib *);
 void pic_export(pic_state *, pic_sym *);
 
 PIC_NORETURN void pic_panic(pic_state *, const char *);

extlib/benz/lib.c

@@ -54,262 +54,26 @@ pic_find_library(pic_state *pic, pic_value spec)
   return pic_lib_ptr(pic_cdr(pic, v));
 }
 
-static void
+void
-import_table(pic_state *pic, pic_value spec, struct pic_dict *imports)
+pic_import(pic_state *pic, struct pic_lib *lib)
 {
-  struct pic_lib *lib;
+  pic_sym *name, *realname, *uid;
-  struct pic_dict *table;
+  xh_entry *it;
-  pic_value val, tmp, prefix, it;
-  pic_sym *sym, *id, *tag, *nick;
-  xh_entry *iter;
 
-  table = pic_make_dict(pic);
+  pic_dict_for_each (name, lib->exports, it) {
-
+    realname = pic_sym_ptr(pic_dict_ref(pic, lib->exports, name));
-  if (pic_pair_p(spec) && pic_sym_p(pic_car(pic, spec))) {
-
-    tag = pic_sym_ptr(pic_car(pic, spec));
-
-    if (tag == pic->sONLY) {
-      import_table(pic, pic_cadr(pic, spec), table);
-
-      pic_for_each (val, pic_cddr(pic, spec), it) {
-        pic_dict_set(pic, imports, pic_sym_ptr(val), pic_dict_ref(pic, table, pic_sym_ptr(val)));
-      }
-      return;
-    }
-    if (tag == pic->sRENAME) {
-      import_table(pic, pic_cadr(pic, spec), imports);
-
-      pic_for_each (val, pic_cddr(pic, spec), it) {
-        tmp = pic_dict_ref(pic, imports, pic_sym_ptr(pic_car(pic, val)));
-        pic_dict_del(pic, imports, pic_sym_ptr(pic_car(pic, val)));
-        pic_dict_set(pic, imports, pic_sym_ptr(pic_cadr(pic, val)), tmp);
-      }
-      return;
-    }
-    if (tag == pic->sPREFIX) {
-      import_table(pic, pic_cadr(pic, spec), table);
-
-      prefix = pic_list_ref(pic, spec, 2);
-      pic_dict_for_each (sym, table, iter) {
-        id = pic_intern(pic, pic_format(pic, "~s~s", prefix, pic_obj_value(sym)));
-        pic_dict_set(pic, imports, id, pic_dict_ref(pic, table, sym));
-      }
-      return;
-    }
-    if (tag == pic->sEXCEPT) {
-      import_table(pic, pic_cadr(pic, spec), imports);
-      pic_for_each (val, pic_cddr(pic, spec), it) {
-        pic_dict_del(pic, imports, pic_sym_ptr(val));
-      }
-      return;
-    }
-  }
-  lib = pic_find_library(pic, spec);
-  if (! lib) {
-    pic_errorf(pic, "library not found: ~a", spec);
-  }
-  pic_dict_for_each (nick, lib->exports, iter) {
-    pic_sym *realname, *uid;
-
-    realname = pic_sym_ptr(pic_dict_ref(pic, lib->exports, nick));
 
     if ((uid = pic_find_variable(pic, lib->env, pic_obj_value(realname))) == NULL) {
       pic_errorf(pic, "attempted to export undefined variable '~s'", pic_obj_value(realname));
     }
-    pic_dict_set(pic, imports, nick, pic_obj_value(uid));
+    pic_put_variable(pic, pic->lib->env, pic_obj_value(name), uid);
   }
 }
 
-static void
-import(pic_state *pic, pic_value spec)
-{
-  struct pic_dict *imports;
-  pic_sym *sym;
-  xh_entry *it;
-
-  imports = pic_make_dict(pic);
-
-  import_table(pic, spec, imports);
-
-  pic_dict_for_each (sym, imports, it) {
-    pic_put_variable(pic, pic->lib->env, pic_obj_value(sym), pic_sym_ptr(pic_dict_ref(pic, imports, sym)));
-  }
-}
-
-static void
-export(pic_state *pic, pic_value spec)
-{
-  pic_sym *sRENAME = pic_intern_cstr(pic, "rename");
-  pic_value a, b;
-
-  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_obj_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 DEBUG
-  printf("* exporting %s as %s\n", pic_symbol_name(pic, pic_sym_ptr(b)), pic_symbol_name(pic, pic_sym_ptr(a)));
-#endif
-
-  pic_dict_set(pic, pic->lib->exports, pic_sym_ptr(b), a);
-
-  return;
-
- fail:
-  pic_errorf(pic, "illegal export spec: ~s", spec);
-}
-
 void
-pic_import(pic_state *pic, pic_value spec)
+pic_export(pic_state *pic, pic_sym *name)
 {
-  import(pic, spec);
+  pic_dict_set(pic, pic->lib->exports, name, pic_obj_value(name));
-}
-
-void
-pic_import_library(pic_state *pic, struct pic_lib *lib)
-{
-  import(pic, lib->name);
-}
-
-void
-pic_export(pic_state *pic, pic_sym *sym)
-{
-  export(pic, pic_obj_value(sym));
-}
-
-static bool
-condexpand(pic_state *pic, pic_value clause)
-{
-  pic_sym *tag;
-  pic_value c, feature, it;
-
-  if (pic_eq_p(clause, pic_obj_value(pic->sELSE))) {
-    return true;
-  }
-  if (pic_sym_p(clause)) {
-    pic_for_each (feature, pic->features, it) {
-      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_ptr(pic_car(pic, clause));
-  }
-
-  if (tag == pic->sLIBRARY) {
-    return pic_find_library(pic, pic_list_ref(pic, clause, 1)) != NULL;
-  }
-  if (tag == pic->sNOT) {
-    return ! condexpand(pic, pic_list_ref(pic, clause, 1));
-  }
-  if (tag == pic->sAND) {
-    pic_for_each (c, pic_cdr(pic, clause), it) {
-      if (! condexpand(pic, c))
-        return false;
-    }
-    return true;
-  }
-  if (tag == pic->sOR) {
-    pic_for_each (c, pic_cdr(pic, clause), it) {
-      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_obj_value(pic->sBEGIN), pic_cdr(pic, clauses[i]));
-    }
-  }
-
-  return pic_undef_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_undef_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_undef_value();
-}
-
-static pic_value
-pic_lib_define_library(pic_state *pic)
-{
-  struct pic_lib *lib, *prev = pic->lib;
-  size_t argc, i;
-  pic_value spec, *argv;
-
-  pic_get_args(pic, "o*", &spec, &argc, &argv);
-
-  if ((lib = pic_find_library(pic, spec)) == NULL) {
-    lib = pic_make_library(pic, spec);
-  }
-
-  pic_try {
-    pic->lib = lib;
-
-    for (i = 0; i < argc; ++i) {
-      pic_void(pic_eval(pic, argv[i], pic->lib->env));
-    }
-
-    pic->lib = prev;
-  }
-  pic_catch {
-    pic->lib = prev;   /* restores pic->lib even if an error occured */
-    pic_raise(pic, pic->err);
-  }
-
-  return pic_undef_value();
 }
 
 static pic_value
@@ -336,6 +100,86 @@ pic_lib_find_library(pic_state *pic)
   return pic_obj_value(lib);
 }
 
+static pic_value
+pic_lib_current_library(pic_state *pic)
+{
+  pic_value lib;
+  size_t n;
+
+  n = pic_get_args(pic, "|o", &lib);
+
+  if (n == 0) {
+    return pic_obj_value(pic->lib);
+  }
+  else {
+    pic_assert_type(pic, lib, lib);
+
+    pic->lib = pic_lib_ptr(lib);
+
+    return pic_undef_value();
+  }
+}
+
+static pic_value
+pic_lib_library_import(pic_state *pic)
+{
+  pic_value lib_opt;
+  pic_sym *name, *realname, *uid, *alias = NULL;
+  struct pic_lib *lib;
+
+  pic_get_args(pic, "om|m", &lib_opt, &name, &alias);
+
+  pic_assert_type(pic, lib_opt, lib);
+
+  if (alias == NULL) {
+    alias = name;
+  }
+
+  lib = pic_lib_ptr(lib_opt);
+
+  if (! pic_dict_has(pic, lib->exports, name)) {
+    pic_errorf(pic, "attempted to import undefined variable '~s'", pic_obj_value(name));
+  } else {
+    realname = pic_sym_ptr(pic_dict_ref(pic, lib->exports, name));
+  }
+
+  if ((uid = pic_find_variable(pic, lib->env, pic_obj_value(realname))) == NULL) {
+    pic_errorf(pic, "attempted to export undefined variable '~s'", pic_obj_value(realname));
+  } else {
+    pic_put_variable(pic, pic->lib->env, pic_obj_value(alias), uid);
+  }
+
+  return pic_undef_value();
+}
+
+static pic_value
+pic_lib_library_export(pic_state *pic)
+{
+  pic_sym *name, *alias = NULL;
+
+  pic_get_args(pic, "m|m", &name, &alias);
+
+  if (alias == NULL) {
+    alias = name;
+  }
+
+  pic_dict_set(pic, pic->lib->exports, alias, pic_obj_value(name));
+
+  return pic_undef_value();
+}
+
+static pic_value
+pic_lib_library_name(pic_state *pic)
+{
+  pic_value lib;
+
+  pic_get_args(pic, "o", &lib);
+
+  pic_assert_type(pic, lib, lib);
+
+  return pic_lib_ptr(lib)->name;
+}
+
 static pic_value
 pic_lib_library_exports(pic_state *pic)
 {
@@ -369,15 +213,13 @@ pic_lib_library_environment(pic_state *pic)
 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->uCOND_EXPAND, pic_lib_condexpand);
-  pic_defmacro(pic, pic->sIMPORT, pic->uIMPORT, pic_lib_import);
-  pic_defmacro(pic, pic->sEXPORT, pic->uEXPORT, pic_lib_export);
-  pic_defmacro(pic, pic->sDEFINE_LIBRARY, pic->uDEFINE_LIBRARY, pic_lib_define_library);
-
   pic_defun(pic, "make-library", pic_lib_make_library);
   pic_defun(pic, "find-library", pic_lib_find_library);
+  pic_defun(pic, "library-name", pic_lib_library_name);
   pic_defun(pic, "library-exports", pic_lib_library_exports);
   pic_defun(pic, "library-environment", pic_lib_library_environment);
+
+  pic_defun(pic, "current-library", pic_lib_current_library);
+  pic_defun(pic, "library-import", pic_lib_library_import);
+  pic_defun(pic, "library-export", pic_lib_library_export);
 }

extlib/benz/state.c

@@ -91,6 +91,14 @@ pic_init_features(pic_state *pic)
 #endif
 }
 
+static pic_value
+pic_features(pic_state *pic)
+{
+  pic_get_args(pic, "");
+
+  return pic->features;
+}
+
 #define DONE pic_gc_arena_restore(pic, ai);
 
 static void
@@ -111,6 +119,8 @@ pic_init_core(pic_state *pic)
     pic_define_syntactic_keyword(pic, pic->lib->env, pic->sBEGIN, pic->uBEGIN);
     pic_define_syntactic_keyword(pic, pic->lib->env, pic->sDEFINE_MACRO, pic->uDEFINE_MACRO);
 
+    pic_defun(pic, "features", pic_features);
+
     pic_init_undef(pic); DONE;
     pic_init_bool(pic); DONE;
     pic_init_pair(pic); DONE;
@@ -138,7 +148,7 @@ pic_init_core(pic_state *pic)
     pic_load_cstr(pic, &pic_boot[0][0]);
   }
 
-  pic_import_library(pic, pic->PICRIN_BASE);
+  pic_import(pic, pic->PICRIN_BASE);
 }
 
 pic_state *

piclib/picrin/base.scm

@@ -254,6 +254,8 @@
 
   (export make-library
           find-library
+          current-library
+          library-name
           library-exports
           library-environment)
 
@@ -284,4 +286,6 @@
           write-shared
           display)
 
-  (export eval))
+  (export eval)
+
+  (export features))

src/main.c

@@ -7,14 +7,6 @@
 void pic_init_contrib(pic_state *);
 void pic_load_piclib(pic_state *);
 
-static pic_value
-pic_features(pic_state *pic)
-{
-  pic_get_args(pic, "");
-
-  return pic->features;
-}
-
 static pic_value
 pic_libraries(pic_state *pic)
 {
@@ -38,10 +30,6 @@ pic_init_picrin(pic_state *pic)
     pic_defun(pic, "libraries", pic_libraries);
   }
 
-  pic_deflibrary (pic, "(scheme base)") {
-    pic_defun(pic, "features", pic_features);
-  }
-
   pic_init_contrib(pic);
   pic_load_piclib(pic);
 }