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;