Commit 0f738db0481cc67415babbd7ac032d30bd450e73

Thomas de Grivel 2023-03-04T13:02:48

wip

diff --git a/libc3/buf_inspect.c b/libc3/buf_inspect.c
index 66a3d80..0847ba1 100644
--- a/libc3/buf_inspect.c
+++ b/libc3/buf_inspect.c
@@ -93,6 +93,57 @@ sw buf_inspect_call_size (const s_call *call)
   return result;
 }
 
+sw buf_inspect_cfn (s_buf *buf, const s_cfn *cfn)
+{
+  s_list *arg_type;
+  sw r;
+  sw result = 0;
+  assert(cfn);
+  if ((r = buf_inspect_sym(buf, cfn->name)) < 0)
+    return r;
+  result += r;
+  if ((r = buf_write_1(buf, "(")) < 0)
+    return r;
+  result += r;
+  arg_type = cfn->arg_types;
+  while (arg_type) {
+    if ((r = buf_inspect_tag(buf, &arg_type->tag)) < 0)
+      return r;
+    arg_type = list_next(arg_type);
+    if (arg_type) {
+      if ((r = buf_write_1(buf, ", ")) < 0)
+        return r;
+      result += r;
+    }
+  }
+  if ((r = buf_write_1(buf, ")")) < 0)
+    return r;
+  result += r;
+  return result;
+}
+
+sw buf_inspect_cfn_size (const s_cfn *cfn)
+{
+  s_list *arg_type;
+  sw r;
+  sw result = 0;
+  assert(cfn);
+  if ((r = buf_inspect_sym_size(cfn->name)) < 0)
+    return r;
+  result += r;
+  result += strlen("(");
+  arg_type = cfn->arg_types;
+  while (arg_type) {
+    if ((r = buf_inspect_tag_size(&arg_type->tag)) < 0)
+      return r;
+    arg_type = list_next(arg_type);
+    if (arg_type)
+      result += strlen(", ");
+  }
+  result += strlen(")");
+  return result;
+}
+
 sw buf_inspect_character (s_buf *buf, character x)
 {
   sw r;
@@ -914,6 +965,7 @@ sw buf_inspect_tag (s_buf *buf, const s_tag *tag)
   case TAG_CALL_FN:
   case TAG_CALL_MACRO:
                     return buf_inspect_call(buf, &tag->data.call);
+  case TAG_CFN:     return buf_inspect_cfn(buf, &tag->data.cfn);
   case TAG_CHARACTER:
     return buf_inspect_character(buf, tag->data.character);
   case TAG_F32:     return buf_inspect_f32(buf, tag->data.f32);
@@ -951,6 +1003,7 @@ sw buf_inspect_tag_size (const s_tag *tag)
   case TAG_CALL_FN:
   case TAG_CALL_MACRO:
     return buf_inspect_call_size(&tag->data.call);
+  case TAG_CFN:      return buf_inspect_cfn_size(&tag->data.cfn);
   case TAG_CHARACTER:
     return buf_inspect_character_size(tag->data.character);
   case TAG_F32:      return buf_inspect_f32_size(tag->data.f32);
diff --git a/libc3/buf_inspect.h b/libc3/buf_inspect.h
index 0d250fd..5d6ecec 100644
--- a/libc3/buf_inspect.h
+++ b/libc3/buf_inspect.h
@@ -31,6 +31,8 @@ sw buf_inspect_bool_size (e_bool b);
 sw buf_inspect_call (s_buf *buf, const s_call *call);
 sw buf_inspect_call_args (s_buf *buf, const s_list *args);
 sw buf_inspect_call_size (const s_call *call);
+sw buf_inspect_cfn (s_buf *buf, const s_cfn *cfn);
+sw buf_inspect_cfn_size (const s_cfn *cfn);
 sw buf_inspect_character (s_buf *buf, character c);
 sw buf_inspect_character_size (character c);
 sw buf_inspect_error_handler (s_buf *buf,
diff --git a/libc3/c3.h b/libc3/c3.h
index 1e1a10e..3de4164 100644
--- a/libc3/c3.h
+++ b/libc3/c3.h
@@ -22,6 +22,7 @@
 #include "buf_parse.h"
 #include "buf_save.h"
 #include "call.h"
+#include "cfn.h"
 #include "character.h"
 #include "compare.h"
 #include "env.h"
diff --git a/libc3/cfn.c b/libc3/cfn.c
index 6eba261..51cb348 100644
--- a/libc3/cfn.c
+++ b/libc3/cfn.c
@@ -89,4 +89,25 @@ s_tag * cfn_apply (s_cfn *cfn, s_list *args) {
 
   return result;
 }
-#endif /* CFN_H */
+
+void cfn_clean (s_cfn *cfn)
+{
+  assert(cfn);
+  list_delete_all(cfn->arg_types);
+}
+
+s_cfn * cfn_copy (const s_cfn *cfn, s_cfn *dest)
+{
+  assert(cfn);
+  assert(dest);
+  dest->name = cfn->name;
+  dest->arg_types = list_copy(cfn->arg_types);
+  return dest;
+}
+
+s_cfn * cfn_init (s_cfn *cfn)
+{
+  assert(cfn);
+  bzero(cfn, sizeof(s_cfn));
+  return cfn;
+}
diff --git a/libc3/cfn.h b/libc3/cfn.h
index 0c5a90a..cdaab31 100644
--- a/libc3/cfn.h
+++ b/libc3/cfn.h
@@ -18,6 +18,9 @@
 
 /* stack-allocation compatible functions */
 s_cfn * cfn_init (s_cfn *cfn);
-void cfn_clean (s_cfn *cfn);
+void    cfn_clean (s_cfn *cfn);
+
+/* observers */
+s_cfn * cfn_copy (const s_cfn *cfn, s_cfn *dest);
 
 #endif /* CFN_H */
diff --git a/libc3/compare.c b/libc3/compare.c
index 5a7091c..644973d 100644
--- a/libc3/compare.c
+++ b/libc3/compare.c
@@ -51,6 +51,20 @@ s8 compare_call (const s_call *a, const s_call *b)
   return compare_list(a->arguments, b->arguments);
 }
 
+s8 compare_cfn (const s_fn *a, const s_fn *b)
+{
+  s8 r;
+  if (a == b)
+    return 0;
+  if (!a)
+    return -1;
+  if (!b)
+    return 1;
+  if ((r = compare_sym(&a->name, &b->name)))
+    return r;
+  return compare_list(a->arg_types, b->arg_types);
+}
+
 COMPARE_DEF(character)
 
 COMPARE_DEF(f32)
@@ -136,6 +150,20 @@ s8 compare_fact_osp (const s_fact *a, const s_fact *b)
   return r;
 }
 
+s8 compare_fn (const s_fn *a, const s_fn *b)
+{
+  s8 r;
+  if (a == b)
+    return 0;
+  if (!a)
+    return -1;
+  if (!b)
+    return 1;
+  if ((r = compare_ident(&a->ident, &b->ident)))
+    return r;
+  return compare_list(a->arguments, b->arguments);
+}
+
 s8 compare_ident (const s_ident *a, const s_ident *b)
 {
   sw r;
@@ -313,11 +341,12 @@ s8 compare_tag (const s_tag *a, const s_tag *b) {
   case TAG_CALL_FN:
   case TAG_CALL_MACRO:
     return compare_call(&a->data.call, &b->data.call);
+  case TAG_CFN: return compare_cfn(&a->data.cfn, &b->data.cfn);
   case TAG_CHARACTER: return compare_character(a->data.character,
                                                b->data.character);
   case TAG_F32: return compare_f32(a->data.f32, b->data.f32);
   case TAG_F64: return compare_f64(a->data.f64, b->data.f64);
-  case TAG_FN: return compare_ptr(a, b);
+  case TAG_FN: return compare_fn(a->data.fn, b->data.fn);
   case TAG_IDENT: return compare_ident(&a->data.ident, &b->data.ident);
   case TAG_INTEGER: return compare_integer(&a->data.integer,
                                            &b->data.integer);
diff --git a/libc3/compare.h b/libc3/compare.h
index a1fd9da..a623247 100644
--- a/libc3/compare.h
+++ b/libc3/compare.h
@@ -21,6 +21,7 @@
 
 s8 compare_bool (e_bool a, e_bool b);
 s8 compare_call (const s_call *a, const s_call *b);
+s8 compare_cfn (const s_cfn *a, const s_cfn *b);
 s8 compare_character (character a, character b);
 COMPARE_PROTOTYPE(f32);
 COMPARE_PROTOTYPE(f64);
@@ -29,6 +30,7 @@ s8 compare_fact_pos (const s_fact *a, const s_fact *b);
 s8 compare_fact_osp (const s_fact *a, const s_fact *b);
 s8 compare_fact_unbound_var_count (const s_fact *a,
                                    const s_fact *b);
+s8 compare_fn (const s_fn *a, const s_fn *b);
 s8 compare_ident (const s_ident *a, const s_ident *b);
 s8 compare_integer (const s_integer *a, const s_integer *b);
 s8 compare_integer_s64 (const s_integer *a, s64 b);
diff --git a/libc3/env.c b/libc3/env.c
index 0d57e8b..ab7ccbd 100644
--- a/libc3/env.c
+++ b/libc3/env.c
@@ -283,6 +283,7 @@ bool env_eval_equal_tag (s_env *env, const s_tag *a, const s_tag *b,
   case TAG_CALL:
   case TAG_CALL_FN:
   case TAG_CALL_MACRO:
+  case TAG_CFN:
   case TAG_CHARACTER:
   case TAG_F32:
   case TAG_F64:
@@ -383,6 +384,7 @@ bool env_eval_tag (s_env *env, const s_tag *tag, s_tag *dest)
   case TAG_IDENT:
     return env_eval_ident(env, &tag->data.ident, dest);
   case TAG_BOOL:
+  case TAG_CFN:
   case TAG_CHARACTER:
   case TAG_F32:
   case TAG_F64:
diff --git a/libc3/hash.c b/libc3/hash.c
index 029bd93..447db5f 100644
--- a/libc3/hash.c
+++ b/libc3/hash.c
@@ -79,6 +79,16 @@ void hash_update_call (t_hash *hash, const s_call *call)
   hash_update_list(hash, call->arguments);
 }
 
+void hash_update_cfn (t_hash *hash, const s_cfn *cfn)
+{
+  const s8 type[] = "cfn";
+  assert(hash);
+  assert(cfn);
+  hash_update(hash, type, sizeof(type));
+  hash_update_sym(hash, cfn->name);
+  hash_update_list(hash, cfn->arg_types);
+}
+
 HASH_UPDATE_DEF(character)
 
 HASH_UPDATE_DEF(f32)
@@ -88,6 +98,8 @@ HASH_UPDATE_DEF(f64)
 void hash_update_fact (t_hash *hash, const s_fact *fact)
 {
   const u8 type = 3;
+  assert(hash);
+  assert(fact);
   hash_update(hash, &type, sizeof(type));
   hash_update_tag(hash, fact->subject);
   hash_update_tag(hash, fact->predicate);
@@ -97,6 +109,8 @@ void hash_update_fact (t_hash *hash, const s_fact *fact)
 void hash_update_fn (t_hash *hash, const s_fn *fn)
 {
   const s8 type[] = "fn";
+  assert(hash);
+  assert(fn);
   hash_update(hash, type, sizeof(type));
   while (fn) {
     hash_update_list(hash, fn->pattern);
@@ -198,6 +212,7 @@ void hash_update_tag (t_hash *hash, const s_tag *tag)
   case TAG_CALL_FN:
   case TAG_CALL_MACRO:
     hash_update_call(hash, &tag->data.call);                   break;
+  case TAG_CFN: hash_update_cfn(hash, &tag->data.cfn);         break;
   case TAG_CHARACTER:
     hash_update_character(hash, tag->data.character);          break;
   case TAG_F32: hash_update_f32(hash, tag->data.f32);          break;
diff --git a/libc3/hash.h b/libc3/hash.h
index 6fe7e02..74d7ad9 100644
--- a/libc3/hash.h
+++ b/libc3/hash.h
@@ -27,6 +27,7 @@ void hash_update (t_hash *hash, const void *data, uw size);
 void hash_update_1 (t_hash *hash, const s8 *p);
 void hash_update_bool (t_hash *hash, e_bool b);
 void hash_update_call (t_hash *hash, const s_call *call);
+void hash_update_cfn (t_hash *hash, const s_cfn *cfn);
 HASH_UPDATE_PROTOTYPE(f32);
 HASH_UPDATE_PROTOTYPE(f64);
 void hash_update_fact (t_hash *hash, const s_fact *fact);
diff --git a/libc3/sym.h b/libc3/sym.h
index 43f9adf..72ef391 100644
--- a/libc3/sym.h
+++ b/libc3/sym.h
@@ -49,4 +49,6 @@ e_bool sym_is_module (const s_sym *sym);
 
 const s_sym * sym_new (const s_str *src);
 
+e_tag_type sym_to_e_tag_type(const s_sym *sym);
+
 #endif /* SYM_H */
diff --git a/libc3/tag.c b/libc3/tag.c
index 812e5e6..aee39a8 100644
--- a/libc3/tag.c
+++ b/libc3/tag.c
@@ -17,7 +17,6 @@
 #include <string.h>
 #include <strings.h>
 #include "c3.h"
-#include "../libffi/ffi.h"
 
 s_tag g_tag_first;
 s_tag g_tag_last;
@@ -121,6 +120,7 @@ void tag_clean (s_tag *tag)
   case TAG_CALL:
   case TAG_CALL_FN:
   case TAG_CALL_MACRO: call_clean(&tag->data.call);       break;
+  case TAG_CFN:        cfn_clean(&tag->data.cfn);         break;
   case TAG_FN:         fn_delete_all(tag->data.fn);       break;
   case TAG_INTEGER:    integer_clean(&tag->data.integer); break;
   case TAG_LIST:       list_delete_all(tag->data.list);   break;
@@ -162,6 +162,9 @@ s_tag * tag_copy (const s_tag *src, s_tag *dest)
   case TAG_CALL_MACRO:
     call_copy(&src->data.call, &dest->data.call);
     break;
+  case TAG_CFN:
+    cfn_copy(&src->data.cfn, &dest->data.cfn);
+    break;
   case TAG_FN:
     fn_copy(src->data.fn, &dest->data.fn);
     break;
diff --git a/libc3/types.h b/libc3/types.h
index 6261e22..d1d2b7b 100644
--- a/libc3/types.h
+++ b/libc3/types.h
@@ -18,6 +18,7 @@
 #include <setjmp.h>
 #include <stdio.h>
 #include <sys/types.h>
+#include <ffi.h>
 #include "config.h"
 #include "sha1.h"
 #include "../libtommath/tommath.h"
@@ -142,6 +143,9 @@ struct buf_save {
 struct cfn {
   const s_sym *name;
   void *p;
+  u8 arity;
+  s_list *arg_types;
+  ffi_cif cif;
 };
 
 struct fact {
@@ -296,7 +300,7 @@ struct sym {
 union tag_data {
   bool         bool;
   s_call       call;
-  s_cfn       *cfn;
+  s_cfn        cfn;
   character    character;
   f32          f32;
   f64          f64;