kc3-lang/kc3

diff --git a/lib/c3/0.1/c3.facts b/lib/c3/0.1/c3.facts
index dddf44d..e242898 100644
--- a/lib/c3/0.1/c3.facts
+++ b/lib/c3/0.1/c3.facts
@@ -228,3 +228,7 @@ add {C3, :symbol, C3.quote_cfn}
 replace {C3.quote_cfn, :arity, 1}
 replace {C3.quote_cfn, :is_a, :special_operator}
 replace {C3.quote_cfn, :symbol_value, cfn Tag "c3_quote_cfn" (Sym, Result)}
+add {C3, :symbol, C3.defoperator}
+replace {C3.defoperator, :arity, 5}
+replace {C3.defoperator, :is_a, :special_operator}
+replace {C3.defoperator, :symbol_value, cfn Tag "c3_defoperator" (Sym, Sym, Tag, U8, Sym, Result)}
diff --git a/libc3/c3.c b/libc3/c3.c
index 62ac697..97b4f46 100644
--- a/libc3/c3.c
+++ b/libc3/c3.c
@@ -55,6 +55,17 @@ s_tag * c3_defmodule (const s_sym **name, const s_block *block, s_tag *dest)
   return env_defmodule(&g_c3_env, name, block, dest);
 }
 
+s_tag * c3_defoperator (const s_sym **name, const s_sym **sym,
+                        const s_tag *symbol_value,
+                        u8 operator_precedence,
+                        const s_sym **operator_associativity,
+                        s_tag *dest)
+{
+  return env_defoperator(&g_c3_env, name, sym, symbol_value,
+                         operator_precedence,
+                         operator_associativity, dest);
+}
+
 void ** c3_dlopen (const s_str *path, void **dest)
 {
   assert(path);
diff --git a/libc3/c3_main.h b/libc3/c3_main.h
index 357db11..ba5a638 100644
--- a/libc3/c3_main.h
+++ b/libc3/c3_main.h
@@ -37,6 +37,11 @@ void    c3_license (void);
 /* Operators. */
 s_tag * c3_def (const s_call *call, s_tag *dest);
 s_tag * c3_defmodule (const s_sym **name, const s_block *block, s_tag *dest);
+s_tag * c3_defoperator (const s_sym **name, const s_sym **sym,
+                        const s_tag *symbol_value,
+                        u8 operator_precedence,
+                        const s_sym **operator_associativity,
+                        s_tag *dest);
 void ** c3_dlopen (const s_str *path, void **dest);
 void    c3_exit (sw code);
 s_tag * c3_pin (const s_tag *a, s_tag *dest);
diff --git a/libc3/cfn.c b/libc3/cfn.c
index e0a549b..107e67a 100644
--- a/libc3/cfn.c
+++ b/libc3/cfn.c
@@ -132,6 +132,18 @@ s_tag * cfn_apply (s_cfn *cfn, s_list *args, s_tag *dest)
   return NULL;
 }
 
+s8 cfn_arity (const s_cfn *cfn)
+{
+  sw arity;
+  arity = cfn->arity - (cfn->arg_result ? 1 : 0);
+  if (arity < 0 || arity > S8_MAX) {
+    err_puts("fn_arity: invalid arity");
+    assert(! "fn_arity: invalid arity");
+    return -1;
+  }
+  return arity;
+}
+
 void cfn_clean (s_cfn *cfn)
 {
   assert(cfn);
diff --git a/libc3/cfn.h b/libc3/cfn.h
index ba1e20a..3b1da26 100644
--- a/libc3/cfn.h
+++ b/libc3/cfn.h
@@ -28,6 +28,7 @@ s_cfn * cfn_new_copy (const s_cfn *src);
 
 /* Observers */
 s_tag * cfn_apply (s_cfn *cfn, s_list *args, s_tag *dest);
+s8      cfn_arity (const s_cfn *cfn);
 
 /* Modifiers */
 s_cfn * cfn_link (s_cfn *cfn);
diff --git a/libc3/env.c b/libc3/env.c
index 92f9883..fa3bada 100644
--- a/libc3/env.c
+++ b/libc3/env.c
@@ -140,6 +140,57 @@ s_tag * env_defmodule (s_env *env, const s_sym **name,
   return result;
 }
 
+s_tag * env_defoperator (s_env *env, const s_sym **name,
+                         const s_sym **sym, const s_tag *symbol_value,
+                         u8 operator_precedence,
+                         const s_sym **operator_associativity,
+                         s_tag *dest)
+{
+  s8 arity;
+  s_tag tag_module_name;
+  s_tag tag_operator;
+  s_tag tag_ident;
+  s_tag tag_is_a;
+  s_tag tag_symbol;
+  s_tag tag_sym;
+  s_tag tag_arity_sym;
+  s_tag tag_arity_u8;
+  s_tag tag_symbol_value;
+  s_tag tag_operator_precedence_sym;
+  s_tag tag_operator_precedence_u8;
+  s_tag tag_operator_associativity_rel;
+  s_tag tag_operator_associativity_value;
+  tag_init_sym(&tag_module_name, env->current_module);
+  tag_init_sym(&tag_operator, &g_sym_operator);
+  tag_ident.type = TAG_IDENT;
+  tag_ident.data.ident.module = env->current_module;
+  tag_ident.data.ident.sym = *name;
+  tag_init_sym(&tag_is_a, &g_sym_is_a);
+  tag_init_sym(&tag_symbol, &g_sym_symbol);
+  tag_init_sym(&tag_sym, *sym);
+  tag_init_sym(&tag_arity_sym, &g_sym_arity);
+  arity = tag_arity(symbol_value);
+  if (arity < 1) {
+    err_write_1("env_defoperator: invalid arity: ");
+    err_inspect_s8(&arity);
+    err_write_1("\n");
+    assert(! "env_defoperator: invalid arity");
+  };
+  tag_init_u8( &tag_arity_u8, arity);
+  tag_init_sym(&tag_symbol_value, &g_sym_symbol_value);
+  tag_init_sym(&tag_operator_precedence_sym,
+               &g_sym_operator_precedence);
+  tag_init_u8( &tag_operator_precedence_u8, operator_precedence);
+  tag_init_sym(&tag_operator_associativity_rel,
+               &g_sym_operator_associativity);
+  tag_init_sym(&tag_operator_associativity_value,
+               *operator_associativity);
+  facts_add_tags(&env->facts, &tag_module_name, &tag_operator,
+                 &tag_ident);
+  *dest = tag_ident;
+  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 992c616..51f3f5c 100644
--- a/libc3/env.h
+++ b/libc3/env.h
@@ -31,6 +31,12 @@ s_ident *     env_ident_resolve_module (const s_env *env,
 s_tag *       env_def (s_env *env, const s_call *call, s_tag *dest);
 s_tag *       env_defmodule (s_env *env, const s_sym **name,
                              const s_block *block, s_tag *dest);
+s_tag *       env_defoperator (s_env *env, const s_sym **name,
+                               const s_sym **sym,
+                               const s_tag *symbol_value,
+                               u8 operator_precedence,
+                               const s_sym **operator_associativity,
+                               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/fn.c b/libc3/fn.c
index 3ef6d7d..b528c8e 100644
--- a/libc3/fn.c
+++ b/libc3/fn.c
@@ -22,6 +22,20 @@
 #include "list.h"
 #include "tag_type.h"
 
+s8 fn_arity (const s_fn *fn)
+{
+  assert(fn);
+  if (fn->clauses) {
+    if (fn->clauses->arity > S8_MAX) {
+      err_puts("fn_arity: invalid arity");
+      assert(! "fn_arity: invalid arity");
+      return -1;
+    }
+    return fn->clauses->arity;
+  }
+  return -1;
+}
+
 void fn_clean (s_fn *fn)
 {
   assert(fn);
diff --git a/libc3/fn.h b/libc3/fn.h
index ed2ba7e..4f678e8 100644
--- a/libc3/fn.h
+++ b/libc3/fn.h
@@ -33,4 +33,7 @@ void   fn_delete (s_fn *fn);
 s_fn * fn_new (void);
 s_fn * fn_new_copy (const s_fn *fn);
 
+/* Observers. */
+s8 fn_arity (const s_fn *fn);
+
 #endif /* LIBC3_FN_H */
diff --git a/libc3/tag.c b/libc3/tag.c
index 0232347..90801b4 100644
--- a/libc3/tag.c
+++ b/libc3/tag.c
@@ -64,6 +64,17 @@ bool * tag_and (const s_tag *a, const s_tag *b, bool *dest)
   return dest;
 }
 
+s8 tag_arity (const s_tag *tag)
+{
+  switch (tag->type) {
+  case TAG_CFN: return cfn_arity(&tag->data.cfn);
+  case TAG_FN:  return fn_arity(&tag->data.fn);
+  default:
+    break;
+  }
+  return -1;
+}
+
 s_tag * tag_cast_integer_to_s8 (s_tag *tag)
 {
   s8 i;
diff --git a/libc3/tag.h b/libc3/tag.h
index 89dfaac..d059d50 100644
--- a/libc3/tag.h
+++ b/libc3/tag.h
@@ -41,6 +41,7 @@ s_tag * tag_new (void);
 s_tag * tag_new_1 (const char *p);
 
 /* Observers */
+s8             tag_arity (const s_tag *tag);
 u64            tag_hash_u64 (const s_tag *tag);
 uw             tag_hash_uw (const s_tag *tag);
 s_str *        tag_inspect (const s_tag *tag, s_str *dest);