Commit 968aae789d3fe42409d361ff081a845dff03e421

Thomas de Grivel 2024-03-19T08:24:30

defmodule

diff --git a/lib/c3/0.1/c3.facts b/lib/c3/0.1/c3.facts
index 2c2f0ff..977e6f0 100644
--- a/lib/c3/0.1/c3.facts
+++ b/lib/c3/0.1/c3.facts
@@ -214,3 +214,7 @@ add {C3, :symbol, C3.sqrt}
 replace {C3.sqrt, :cfn, cfn Tag "tag_sqrt" (Tag, Result)}
 add {C3, :symbol, C3.hash}
 replace {C3.hash, :cfn, cfn Uw "tag_hash_uw" (Tag)}
+add {C3, :symbol, C3.defmodule}
+replace {C3.defmodule, :arity, 2}
+replace {C3.defmodule, :is_a, :special_operator}
+replace {C3.defmodule, :cfn, cfn Tag "c3_defmodule" (Sym, Block, Result)}
diff --git a/libc3/c3.c b/libc3/c3.c
index fbf32de..07fe480 100644
--- a/libc3/c3.c
+++ b/libc3/c3.c
@@ -45,6 +45,11 @@ void c3_clean (s_env *env)
   sym_delete_all();
 }
 
+s_tag * c3_defmodule (const s_sym *name, const s_block *block, s_tag *dest)
+{
+  return env_defmodule(&g_c3_env, name, block, dest);
+}
+
 void ** c3_dlopen (const s_str *path, void **dest)
 {
   assert(path);
diff --git a/libc3/env.c b/libc3/env.c
index 509c758..776e9ff 100644
--- a/libc3/env.c
+++ b/libc3/env.c
@@ -68,6 +68,22 @@ void env_clean (s_env *env)
   list_delete_all(env->path);
 }
 
+s_tag * env_defmodule (s_env *env, const s_sym *name,
+                       const s_block *block, s_tag *dest)
+{
+  const s_sym *module;
+  assert(env);
+  assert(name);
+  assert(block);
+  assert(dest);
+  module = env->current_module;
+  env->current_module = name;
+  if (! env_eval_block(env, block, dest))
+    dest = NULL;
+  env->current_module = module;
+  return dest;
+}
+
 void env_error_f (s_env *env, const char *fmt, ...)
 {
   va_list ap;
diff --git a/libc3/env.h b/libc3/env.h
index 0f22ced..396dc7c 100644
--- a/libc3/env.h
+++ b/libc3/env.h
@@ -27,6 +27,8 @@ void          env_ident_resolve_module (const s_env *env,
                                         s_ident *ident);
 
 /* Operators. */
+s_tag *       env_defmodule (s_env *env, const s_sym *name,
+                             const s_block *block, s_tag *dest);
 bool          env_eval_array (s_env *env, const s_array *array,
                               s_array *dest);
 bool          env_eval_array_tag (s_env *env, const s_array *array,
diff --git a/libc3/sym.c b/libc3/sym.c
index d24bd85..d33d0cf 100644
--- a/libc3/sym.c
+++ b/libc3/sym.c
@@ -265,71 +265,71 @@ const s_sym ** sym_init_copy (const s_sym **sym,
 
 void sym_init_g_sym (void)
 {
-  sym_intern(&g_sym__brackets, NULL);
-  sym_intern(&g_sym__paren, NULL);
-  sym_intern(&g_sym__plus, NULL);
-  sym_intern(&g_sym_Array, NULL);
-  sym_intern(&g_sym_Block, NULL);
-  sym_intern(&g_sym_Bool, NULL);
-  sym_intern(&g_sym_C3, NULL);
-  sym_intern(&g_sym_Call, NULL);
-  sym_intern(&g_sym_Cfn, NULL);
-  sym_intern(&g_sym_Character, NULL);
-  sym_intern(&g_sym_Char__star, NULL);
-  sym_intern(&g_sym_Complex, NULL);
-  sym_intern(&g_sym_F32, NULL);
-  sym_intern(&g_sym_F64, NULL);
-  sym_intern(&g_sym_F128, NULL);
-  sym_intern(&g_sym_Fact, NULL);
-  sym_intern(&g_sym_Fn, NULL);
-  sym_intern(&g_sym_Ident, NULL);
-  sym_intern(&g_sym_Integer, NULL);
-  sym_intern(&g_sym_List, NULL);
-  sym_intern(&g_sym_Map, NULL);
-  sym_intern(&g_sym_Ptag, NULL);
-  sym_intern(&g_sym_Ptr, NULL);
-  sym_intern(&g_sym_PtrFree, NULL);
-  sym_intern(&g_sym_Quote, NULL);
-  sym_intern(&g_sym_Ratio, NULL);
-  sym_intern(&g_sym_Result, NULL);
-  sym_intern(&g_sym_S8, NULL);
-  sym_intern(&g_sym_S16, NULL);
-  sym_intern(&g_sym_S32, NULL);
-  sym_intern(&g_sym_S64, NULL);
-  sym_intern(&g_sym_Str, NULL);
-  sym_intern(&g_sym_Struct, NULL);
-  sym_intern(&g_sym_StructType, NULL);
-  sym_intern(&g_sym_Sw, NULL);
-  sym_intern(&g_sym_Sym, NULL);
-  sym_intern(&g_sym_Tag, NULL);
-  sym_intern(&g_sym_Tuple, NULL);
-  sym_intern(&g_sym_U8, NULL);
-  sym_intern(&g_sym_U16, NULL);
-  sym_intern(&g_sym_U32, NULL);
-  sym_intern(&g_sym_U64, NULL);
-  sym_intern(&g_sym_Unquote, NULL);
-  sym_intern(&g_sym_Uw, NULL);
-  sym_intern(&g_sym_Uw_brackets, NULL);
-  sym_intern(&g_sym_Var, NULL);
-  sym_intern(&g_sym_Void, NULL);
-  sym_intern(&g_sym_cast, NULL);
-  sym_intern(&g_sym_defstruct, NULL);
-  sym_intern(&g_sym_do, NULL);
-  sym_intern(&g_sym_else, NULL);
-  sym_intern(&g_sym_end, NULL);
-  sym_intern(&g_sym_if_then_else, NULL);
-  sym_intern(&g_sym_is_a, NULL);
-  sym_intern(&g_sym_load_time, NULL);
-  sym_intern(&g_sym_operator_pin, NULL);
-  sym_intern(&g_sym_r, NULL);
-  sym_intern(&g_sym_rw, NULL);
-  sym_intern(&g_sym_rwx, NULL);
-  sym_intern(&g_sym_rx, NULL);
-  sym_intern(&g_sym_special_operator, NULL);
-  sym_intern(&g_sym_struct_type, NULL);
-  sym_intern(&g_sym_w, NULL);
-  sym_intern(&g_sym_wx, NULL);
-  sym_intern(&g_sym_x, NULL);
+  sym_register(&g_sym__brackets, NULL);
+  sym_register(&g_sym__paren, NULL);
+  sym_register(&g_sym__plus, NULL);
+  sym_register(&g_sym_Array, NULL);
+  sym_register(&g_sym_Block, NULL);
+  sym_register(&g_sym_Bool, NULL);
+  sym_register(&g_sym_C3, NULL);
+  sym_register(&g_sym_Call, NULL);
+  sym_register(&g_sym_Cfn, NULL);
+  sym_register(&g_sym_Character, NULL);
+  sym_register(&g_sym_Char__star, NULL);
+  sym_register(&g_sym_Complex, NULL);
+  sym_register(&g_sym_F32, NULL);
+  sym_register(&g_sym_F64, NULL);
+  sym_register(&g_sym_F128, NULL);
+  sym_register(&g_sym_Fact, NULL);
+  sym_register(&g_sym_Fn, NULL);
+  sym_register(&g_sym_Ident, NULL);
+  sym_register(&g_sym_Integer, NULL);
+  sym_register(&g_sym_List, NULL);
+  sym_register(&g_sym_Map, NULL);
+  sym_register(&g_sym_Ptag, NULL);
+  sym_register(&g_sym_Ptr, NULL);
+  sym_register(&g_sym_PtrFree, NULL);
+  sym_register(&g_sym_Quote, NULL);
+  sym_register(&g_sym_Ratio, NULL);
+  sym_register(&g_sym_Result, NULL);
+  sym_register(&g_sym_S8, NULL);
+  sym_register(&g_sym_S16, NULL);
+  sym_register(&g_sym_S32, NULL);
+  sym_register(&g_sym_S64, NULL);
+  sym_register(&g_sym_Str, NULL);
+  sym_register(&g_sym_Struct, NULL);
+  sym_register(&g_sym_StructType, NULL);
+  sym_register(&g_sym_Sw, NULL);
+  sym_register(&g_sym_Sym, NULL);
+  sym_register(&g_sym_Tag, NULL);
+  sym_register(&g_sym_Tuple, NULL);
+  sym_register(&g_sym_U8, NULL);
+  sym_register(&g_sym_U16, NULL);
+  sym_register(&g_sym_U32, NULL);
+  sym_register(&g_sym_U64, NULL);
+  sym_register(&g_sym_Unquote, NULL);
+  sym_register(&g_sym_Uw, NULL);
+  sym_register(&g_sym_Uw_brackets, NULL);
+  sym_register(&g_sym_Var, NULL);
+  sym_register(&g_sym_Void, NULL);
+  sym_register(&g_sym_cast, NULL);
+  sym_register(&g_sym_defstruct, NULL);
+  sym_register(&g_sym_do, NULL);
+  sym_register(&g_sym_else, NULL);
+  sym_register(&g_sym_end, NULL);
+  sym_register(&g_sym_if_then_else, NULL);
+  sym_register(&g_sym_is_a, NULL);
+  sym_register(&g_sym_load_time, NULL);
+  sym_register(&g_sym_operator_pin, NULL);
+  sym_register(&g_sym_r, NULL);
+  sym_register(&g_sym_rw, NULL);
+  sym_register(&g_sym_rwx, NULL);
+  sym_register(&g_sym_rx, NULL);
+  sym_register(&g_sym_special_operator, NULL);
+  sym_register(&g_sym_struct_type, NULL);
+  sym_register(&g_sym_w, NULL);
+  sym_register(&g_sym_wx, NULL);
+  sym_register(&g_sym_x, NULL);
 
 }
 
@@ -360,7 +360,7 @@ s_str * sym_inspect (const s_sym *sym, s_str *dest)
   return buf_to_str(&tmp, dest);
 }
 
-bool sym_intern (const s_sym *sym, s_sym *free_sym)
+bool sym_register (const s_sym *sym, s_sym *free_sym)
 {
   s_sym_list *tmp;
   assert(sym);
@@ -451,6 +451,10 @@ bool sym_must_clean (const s_sym *sym, bool *must_clean)
   const s_struct_type *st;
   if (sym_is_array_type(sym))
     sym = sym_array_type(sym);
+  if (sym == &g_sym_Block) {
+    *must_clean = true;
+    return true;
+  }
   if (sym == &g_sym_Bool) {
     *must_clean = false;
     return true;
@@ -617,6 +621,10 @@ bool sym_to_ffi_type (const s_sym *sym, ffi_type *result_type,
     *dest = &ffi_type_pointer;
     return true;
   }
+  if (sym == &g_sym_Block) {
+    *dest = &ffi_type_pointer;
+    return true;
+  }
   if (sym == &g_sym_Bool) {
     *dest = &ffi_type_uint8;
     return true;
@@ -751,6 +759,10 @@ bool sym_to_tag_type (const s_sym *sym, e_tag_type *dest)
     *dest = TAG_ARRAY;
     return true;
   }
+  if (sym == &g_sym_Block) {
+    *dest = TAG_BLOCK;
+    return true;
+  }
   if (sym == &g_sym_Bool) {
     *dest = TAG_BOOL;
     return true;
@@ -906,6 +918,10 @@ bool sym_type_size (const s_sym *type, uw *dest)
     *dest = sizeof(s_array);
     return true;
   }
+  if (type == &g_sym_Block) {
+    *dest = sizeof(s_block);
+    return true;
+  }
   if (type == &g_sym_Bool) {
     *dest = sizeof(bool);
     return true;
diff --git a/libc3/sym.h b/libc3/sym.h
index 15bd1c6..8d5ad82 100644
--- a/libc3/sym.h
+++ b/libc3/sym.h
@@ -99,7 +99,7 @@ const s_sym ** sym_init_copy (const s_sym **sym,
                               const s_sym * const *src);
 void           sym_init_g_sym (void);
 const s_sym ** sym_init_str (const s_sym **sym, const s_str *src);
-bool           sym_intern (const s_sym *sym, s_sym *free_sym);
+bool           sym_register (const s_sym *sym, s_sym *free_sym);
 
 /* Heap-allocation functions, call sym_delete_all at exit. */
 void          sym_delete_all (void);