Commit 7628245ed3004a364ca45e0dade9f134399429fe

Thomas de Grivel 2023-07-28T19:48:59

wip ic3

diff --git a/lib/c3/0.1/c3.facts b/lib/c3/0.1/c3.facts
index 848759c..10c0887 100644
--- a/lib/c3/0.1/c3.facts
+++ b/lib/c3/0.1/c3.facts
@@ -17,38 +17,47 @@ add {C3, :symbol, C3.>}
 add {C3, :symbol, C3.break}
 add {C3, :symbol, C3.first}
 add {C3, :symbol, C3.||}
+add {C3.+, :arity, 2}
 add {C3.+, :cfn, cfn :tag "tag_add" (:tag, :tag, :&result)}
 add {C3.+, :is_a, :operator}
 add {C3.+, :operator_precedence, 1}
 add {C3.+, :operator_associativity, :left}
+add {C3.-, :arity, 2}
 add {C3.-, :cfn, cfn :tag "tag_sub" (:tag, :tag, :&result)}
 add {C3.-, :is_a, :operator}
 add {C3.-, :operator_precedence, 1}
 add {C3.-, :operator_associativity, :left}
+add {C3.*, :arity, 2}
 add {C3.*, :cfn, cfn :tag "tag_mul" (:tag, :tag, :&result)}
 add {C3.*, :is_a, :operator}
 add {C3.*, :operator_precedence, 2}
 add {C3.*, :operator_associativity, :left}
+add {C3./, :arity, 2}
 add {C3./, :cfn, cfn :tag "tag_div" (:tag, :tag, :&result)}
 add {C3./, :is_a, :operator}
 add {C3./, :operator_precedence, 2}
 add {C3./, :operator_associativity, :left}
+add {C3.<, :arity, 2}
 add {C3.<, :cfn, cfn :bool "tag_lt" (:tag, :tag)}
 add {C3.<, :is_a, :operator}
 add {C3.<, :operator_precedence, 3}
 add {C3.<, :operator_associativity, :left}
+add {C3.<=, :arity, 2}
 add {C3.<=, :cfn, cfn :bool "tag_lte" (:tag, :tag)}
 add {C3.<=, :is_a, :operator}
 add {C3.<=, :operator_precedence, 3}
 add {C3.<=, :operator_associativity, :left}
+add {C3.==, :arity, 2}
 add {C3.==, :cfn, cfn :bool "tag_eq" (:tag, :tag)}
 add {C3.==, :is_a, :operator}
 add {C3.==, :operator_precedence, 3}
 add {C3.==, :operator_associativity, :left}
+add {C3.>=, :arity, 2}
 add {C3.>=, :cfn, cfn :bool "tag_gte" (:tag, :tag)}
 add {C3.>=, :is_a, :operator}
 add {C3.>=, :operator_precedence, 3}
 add {C3.>=, :operator_associativity, :left}
+add {C3.>, :arity, 2}
 add {C3.>, :cfn, cfn :bool "tag_gt" (:tag, :tag)}
 add {C3.>, :is_a, :operator}
 add {C3.>, :operator_precedence, 3}
@@ -58,10 +67,12 @@ add {C3.!, :cfn, cfn :bool "tag_not" (:tag)}
 add {C3.!, :is_a, :operator}
 add {C3.!, :operator_precedence, 4}
 add {C3.!, :operator_associativity, :left}
+add {C3.&&, :arity, 2}
 add {C3.&&, :cfn, cfn :bool "tag_and" (:tag, :tag)}
 add {C3.&&, :is_a, :operator}
 add {C3.&&, :operator_precedence, 4}
 add {C3.&&, :operator_associativity, :left}
+add {C3.||, :arity, 2}
 add {C3.||, :cfn, cfn :bool "tag_or" (:tag, :tag)}
 add {C3.||, :is_a, :operator}
 add {C3.||, :operator_precedence, 4}
diff --git a/libc3/buf.c b/libc3/buf.c
index ff2ef7f..bb44e4e 100644
--- a/libc3/buf.c
+++ b/libc3/buf.c
@@ -161,6 +161,26 @@ sw buf_ignore_spaces (s_buf *buf)
   return result;
 }
 
+sw buf_ignore_spaces_but_newline (s_buf *buf)
+{
+  character c;
+  sw csize;
+  sw r;
+  sw result = 0;
+  assert(buf);
+  while ((r = buf_peek_character_utf8(buf, &c)) > 0 &&
+         character_is_space(c) &&
+         c != '\n') {
+    csize = r;
+    if ((r = buf_ignore(buf, csize)) < 0)
+      return r;
+    result += csize;
+  }
+  if (! result && r < 0)
+    return r;
+  return result;
+}
+
 s_buf * buf_init (s_buf *buf, bool free, uw size, s8 *p)
 {
   assert(buf);
diff --git a/libc3/buf.h b/libc3/buf.h
index f145112..dc51e07 100644
--- a/libc3/buf.h
+++ b/libc3/buf.h
@@ -47,6 +47,7 @@ sw      buf_ignore (s_buf *buf, uw size);
 sw      buf_ignore_line (s_buf *buf);
 sw      buf_ignore_newline (s_buf *buf);
 sw      buf_ignore_spaces (s_buf *buf);
+sw      buf_ignore_spaces_but_newline (s_buf *buf);
 sw      buf_peek_1 (s_buf *buf, const s8 *p);
 sw      buf_peek_character_utf8 (s_buf *buf, character *p);
 sw      buf_peek_f32 (s_buf *buf, f32 *p);
diff --git a/libc3/buf_parse.c b/libc3/buf_parse.c
index 9608d41..865200f 100644
--- a/libc3/buf_parse.c
+++ b/libc3/buf_parse.c
@@ -535,14 +535,12 @@ sw buf_parse_call_op (s_buf *buf, s_call *dest)
   s_buf_save save;
   assert(buf);
   assert(dest);
-  if ((r = buf_parse_call_op_unary(buf, dest)) > 0)
-    return r;
   buf_save_init(buf, &save);
   call_init_op(&tmp);
   if ((r = buf_parse_tag_primary(buf, &tmp.arguments->tag)) <= 0)
     goto restore;
   result += r;
-  if ((r = buf_ignore_spaces(buf)) < 0)
+  if ((r = buf_ignore_spaces_but_newline(buf)) < 0)
     goto restore;
   result += r;
   if ((r = buf_parse_call_op_rec(buf, &tmp, 0)) <= 0)
@@ -589,13 +587,15 @@ sw buf_parse_call_op_rec (s_buf *buf, s_call *dest, u8 min_precedence)
     r = 0;
     goto restore;
   }
+  if (! operator_is_binary(&next_op))
+    goto restore;
   while (r > 0 && op_precedence >= min_precedence) {
     if ((r = buf_parse_ident(buf, &next_op)) <= 0)
       goto restore;
     result += r;
     op = next_op;
     tmp.ident = op;
-    if ((r = buf_ignore_spaces(buf)) < 0)
+    if ((r = buf_ignore_spaces_but_newline(buf)) < 0)
       goto restore;
     result += r;
     if ((r = buf_parse_tag_primary(buf, right)) <= 0)
@@ -616,7 +616,8 @@ sw buf_parse_call_op_rec (s_buf *buf, s_call *dest, u8 min_precedence)
     next_op_precedence = operator_precedence(&next_op);
     while (r > 0 && (next_op_precedence >= op_precedence ||
                      (operator_is_right_associative(&next_op) &&
-                      next_op_precedence == op_precedence))) {
+                      next_op_precedence == op_precedence)) &&
+           operator_is_binary(&next_op)) {
       call_init_op(&tmp2);
       tmp2.arguments->tag = *right;
       if ((r = buf_parse_call_op_rec(buf, &tmp2, (next_op_precedence > op_precedence) ? op_precedence + 1 : op_precedence)) <= 0) {
@@ -641,6 +642,7 @@ sw buf_parse_call_op_rec (s_buf *buf, s_call *dest, u8 min_precedence)
     list_next(tmp3.arguments)->tag = *right;
     tag_init_call(left, &tmp3);
   }
+ ok:
   call_clean(dest);
   *dest = tmp;
   r = result;
@@ -2066,6 +2068,16 @@ sw buf_parse_tag_call_op (s_buf *buf, s_tag *dest)
   return r;
 }
 
+sw buf_parse_tag_call_op_unary (s_buf *buf, s_tag *dest)
+{
+  sw r;
+  assert(buf);
+  assert(dest);
+  if ((r = buf_parse_call_op_unary(buf, &dest->data.call)) > 0)
+    dest->type = TAG_CALL;
+  return r;
+}
+
 sw buf_parse_tag_cfn (s_buf *buf, s_tag *dest)
 {
   sw r;
@@ -2142,7 +2154,8 @@ sw buf_parse_tag_primary (s_buf *buf, s_tag *dest)
       goto restore;
     result += r;
   }
-  if ((r = buf_parse_tag_bool(buf, dest)) != 0 ||
+  if ((r = buf_parse_tag_call_op_unary(buf, dest)) != 0 ||
+      (r = buf_parse_tag_bool(buf, dest)) != 0 ||
       (r = buf_parse_tag_character(buf, dest)) != 0)
     goto end;
   if ((r = buf_parse_tag_integer(buf, dest)) != 0) {
diff --git a/libc3/env.c b/libc3/env.c
index da72bfd..453ebc1 100644
--- a/libc3/env.c
+++ b/libc3/env.c
@@ -535,6 +535,34 @@ s_module * env_module_load (s_env *env, s_module *module,
   return module;
 }
 
+bool env_operator_is_binary (s_env *env, const s_ident *op)
+{
+  s_facts_with_cursor cursor;
+  s8 r;
+  s_tag tag_ident;
+  s_tag tag_is_a;
+  s_tag tag_arity;
+  s_tag tag_operator;
+  s_tag tag_two;
+  s_ident tmp;
+  assert(env);
+  assert(op);
+  tmp = *op;
+  ident_resolve_module(&tmp, env);
+  tag_init_ident(&tag_ident, &tmp);
+  tag_init_1(    &tag_is_a, ":is_a");
+  tag_init_1(    &tag_operator, ":operator");
+  tag_init_1(    &tag_arity, ":arity");
+  tag_init_1(    &tag_two, "2");
+  facts_with(&env->facts, &cursor, (t_facts_spec) {
+      &tag_ident, &tag_is_a, &tag_operator,
+                  &tag_arity, &tag_two,
+                  NULL, NULL });
+  r = facts_with_cursor_next(&cursor) ? true : false;
+  facts_with_cursor_clean(&cursor);
+  return r;
+}
+
 bool env_operator_is_right_associative (s_env *env, const s_ident *op)
 {
   s_facts_with_cursor cursor;
@@ -558,7 +586,7 @@ bool env_operator_is_right_associative (s_env *env, const s_ident *op)
   return r;
 }
 
-bool env_operator_is_unary(s_env *env, const s_ident *op)
+bool env_operator_is_unary (s_env *env, const s_ident *op)
 {
   s_facts_with_cursor cursor;
   s8 r;
diff --git a/libc3/env.h b/libc3/env.h
index 3d56159..618fd8a 100644
--- a/libc3/env.h
+++ b/libc3/env.h
@@ -44,9 +44,10 @@ bool       env_eval_progn (s_env *env, const s_list *program,
 bool       env_eval_tag (s_env *env, const s_tag *tag, s_tag *dest);
 s_module * env_module_load (s_env *env, s_module *module,
                             const s_sym *name, s_facts *facts);
+bool       env_operator_is_binary (s_env *env, const s_ident *op);
 bool       env_operator_is_right_associative (s_env *env,
                                               const s_ident *op);
-bool       env_operator_is_unary(s_env *env, const s_ident *op);
+bool       env_operator_is_unary (s_env *env, const s_ident *op);
 s8         env_operator_precedence (s_env *env,
                                     const s_ident *op);
 
diff --git a/libc3/operator.c b/libc3/operator.c
index 7fcbf28..b7371db 100644
--- a/libc3/operator.c
+++ b/libc3/operator.c
@@ -13,6 +13,11 @@
 #include <assert.h>
 #include "c3.h"
 
+bool operator_is_binary (const s_ident *op)
+{
+  return env_operator_is_binary(&g_c3_env, op);
+}
+
 bool operator_is_right_associative (const s_ident *op)
 {
   return env_operator_is_right_associative(&g_c3_env, op);
diff --git a/libc3/operator.h b/libc3/operator.h
index fee1fa2..e859fe3 100644
--- a/libc3/operator.h
+++ b/libc3/operator.h
@@ -16,6 +16,7 @@
 #include "types.h"
 
 /* Observers */
+bool operator_is_binary (const s_ident *op);
 bool operator_is_right_associative (const s_ident *op);
 bool operator_is_unary (const s_ident *op);
 s8   operator_precedence (const s_ident *op);