Commit 1f9f33e82be6b08a45f36c97df49e497f6e9592d

Thomas de Grivel 2023-08-09T15:51:52

test

diff --git a/libc3/env.c b/libc3/env.c
index cb56321..fd10d3a 100644
--- a/libc3/env.c
+++ b/libc3/env.c
@@ -334,8 +334,8 @@ bool env_eval_equal_list (s_env *env, const s_list *a, const s_list *b,
 bool env_eval_equal_tag (s_env *env, const s_tag *a, const s_tag *b,
                          s_tag *dest)
 {
-  e_tag_type type_a;
-  e_tag_type type_b;
+  bool is_unbound_a;
+  bool is_unbound_b;
   s_tag tmp_a;
   s_tag tmp_b;
   assert(env);
@@ -344,29 +344,40 @@ bool env_eval_equal_tag (s_env *env, const s_tag *a, const s_tag *b,
   assert(dest);
   tag_init_void(&tmp_a);
   tag_init_void(&tmp_b);
-  type_a = a->type;
-  type_b = b->type;
-  if (type_a == TAG_IDENT &&
-      b->type == TAG_IDENT) {
-    warnx("TAG_IDENT = TAG_IDENT");
+  is_unbound_a = a->type == TAG_IDENT && ! tag_ident_is_bound(a);
+  is_unbound_b = b->type == TAG_IDENT && ! tag_ident_is_bound(b);
+  if (is_unbound_a && is_unbound_b) {
+    warnx("unbound equal on both sides: %s = %s",
+          a->data.ident.sym->str.ptr.ps8,
+          b->data.ident.sym->str.ptr.ps8);
     return false;
   }
-  if (type_a == TAG_CALL) {
+  if (a->type == TAG_IDENT && tag_ident_is_bound(a)) {
+    if (! env_eval_ident(env, &a->data.ident, &tmp_a))
+      return false;
+    a = &tmp_a;
+  }
+  if (b->type == TAG_IDENT && tag_ident_is_bound(b)) {
+    if (! env_eval_ident(env, &b->data.ident, &tmp_b))
+      return false;
+    b = &tmp_b;
+  }
+  if (a->type == TAG_CALL) {
     if (! env_eval_call(env, &a->data.call, &tmp_a))
       return false;
     a = &tmp_a;
   }
-  if (type_b == TAG_CALL) {
+  if (b->type == TAG_CALL) {
     if (! env_eval_call(env, &b->data.call, &tmp_b))
       return false;
     b = &tmp_b;
   }
-  if (type_a == TAG_IDENT) {
+  if (is_unbound_a) {
     tag_copy(b, dest);
     frame_binding_new(env->frame, a->data.ident.sym, dest);
     return true;
   }
-  if (type_b == TAG_IDENT) {
+  if (is_unbound_b) {
     tag_copy(a, dest);
     frame_binding_new(env->frame, b->data.ident.sym, dest);
     return true;
@@ -379,8 +390,6 @@ bool env_eval_equal_tag (s_env *env, const s_tag *a, const s_tag *b,
   case TAG_VOID:
     tag_init_void(dest);
     return true;
-  case TAG_IDENT:
-    error("env_eval_equal_tag: TAG_IDENT");
   case TAG_LIST:
     tag_init_list(dest, NULL);
     return env_eval_equal_list(env, a->data.list, b->data.list,
@@ -400,6 +409,7 @@ bool env_eval_equal_tag (s_env *env, const s_tag *a, const s_tag *b,
   case TAG_F32:
   case TAG_F64:
   case TAG_FN:
+  case TAG_IDENT:
   case TAG_INTEGER:
   case TAG_PTAG:
   case TAG_S16:
@@ -456,9 +466,8 @@ bool env_eval_ident (s_env *env, const s_ident *ident, s_tag *dest)
   assert(ident);
   if (! ((tag = frame_get(env->frame, ident->sym)) ||
          (tag = module_get(env->current_module, ident->sym, &tmp)))) {
-    tag_init_var(dest);
-    frame_binding_new(env->frame, ident->sym, dest);
-    return true;
+    warnx("unbound ident: %s", ident->sym->str.ptr.ps8);
+    return false;
   }
   tag_copy(tag, dest);
   return true;
diff --git a/libc3/tag.c b/libc3/tag.c
index 4b4d1cc..387bd7e 100644
--- a/libc3/tag.c
+++ b/libc3/tag.c
@@ -1088,15 +1088,15 @@ s_tag * tag_ident_1 (s_tag *tag, const s8 *p)
   return tag_init_ident_1(tag, p);
 }
 
-bool tag_ident_is_unbound (const s_tag *tag)
+bool tag_ident_is_bound (const s_tag *tag)
 {
   s_tag tmp;
   assert(tag);
   assert(tag->type == TAG_IDENT);
   return tag->type == TAG_IDENT &&
-    ! (frame_get(g_c3_env.frame, tag->data.ident.sym) ||
-       module_get(g_c3_env.current_module, tag->data.ident.sym,
-                  &tmp));
+    (frame_get(g_c3_env.frame, tag->data.ident.sym) ||
+     module_get(g_c3_env.current_module, tag->data.ident.sym,
+                &tmp));
 }
 
 s_tag * tag_init (s_tag *tag)
@@ -1516,6 +1516,7 @@ bool tag_lte (const s_tag *a, const s_tag *b)
 s_tag * tag_mul (const s_tag *a, const s_tag *b, s_tag *dest)
 {
   s_integer tmp;
+  s_integer tmp2;
   assert(a);
   assert(b);
   assert(dest);
@@ -1859,7 +1860,13 @@ s_tag * tag_mul (const s_tag *a, const s_tag *b, s_tag *dest)
     case TAG_U32:
       return tag_init_u32(dest, a->data.u32 * b->data.u32);
     case TAG_U64:
-      return tag_init_u64(dest, (u64) a->data.u32 * b->data.u64);
+      integer_init_u32(&tmp, a->data.u32);
+      integer_init_u64(&tmp2, b->data.u64);
+      tag_init_integer_zero(dest);
+      integer_mul(&tmp, &tmp2, &dest->data.integer);
+      integer_clean(&tmp);
+      integer_clean(&tmp2);
+      return dest;
     default:
       goto ko;
   }
@@ -1876,21 +1883,69 @@ s_tag * tag_mul (const s_tag *a, const s_tag *b, s_tag *dest)
       integer_clean(&tmp);
       return dest;
     case TAG_S8:
-      return tag_init_s64(dest, (s64) a->data.u64 * (s64) b->data.s8);
+      integer_init_u64(&tmp, a->data.u64);
+      integer_init_s32(&tmp2, (s32) b->data.s8);
+      tag_init_integer_zero(dest);
+      integer_mul(&tmp, &tmp2, &dest->data.integer);
+      integer_clean(&tmp);
+      integer_clean(&tmp2);
+      return dest;
     case TAG_S16:
-      return tag_init_s64(dest, (s64) a->data.u64 * (s64) b->data.s16);
+      integer_init_u64(&tmp, a->data.u64);
+      integer_init_s32(&tmp2, (s32) b->data.s16);
+      tag_init_integer_zero(dest);
+      integer_mul(&tmp, &tmp2, &dest->data.integer);
+      integer_clean(&tmp);
+      integer_clean(&tmp2);
+      return dest;
     case TAG_S32:
-      return tag_init_s64(dest, (s64) a->data.u64 * (s64) b->data.s32);
+      integer_init_u64(&tmp, a->data.u64);
+      integer_init_s32(&tmp2, b->data.s32);
+      tag_init_integer_zero(dest);
+      integer_mul(&tmp, &tmp2, &dest->data.integer);
+      integer_clean(&tmp);
+      integer_clean(&tmp2);
+      return dest;
     case TAG_S64:
-      return tag_init_s64(dest, (s64) a->data.u64 * b->data.s64);
+      integer_init_u64(&tmp, a->data.u64);
+      integer_init_s64(&tmp2, b->data.s64);
+      tag_init_integer_zero(dest);
+      integer_mul(&tmp, &tmp2, &dest->data.integer);
+      integer_clean(&tmp);
+      integer_clean(&tmp2);
+      return dest;
     case TAG_U8:
-      return tag_init_u64(dest, a->data.u64 * (u64) b->data.u8);
+      integer_init_u64(&tmp, a->data.u64);
+      integer_init_u32(&tmp2, (u32) b->data.u8);
+      tag_init_integer_zero(dest);
+      integer_mul(&tmp, &tmp2, &dest->data.integer);
+      integer_clean(&tmp);
+      integer_clean(&tmp2);
+      return dest;
     case TAG_U16:
-      return tag_init_u64(dest, a->data.u64 * (u64) b->data.u16);
+      integer_init_u64(&tmp, a->data.u64);
+      integer_init_u32(&tmp2, (u32) b->data.u16);
+      tag_init_integer_zero(dest);
+      integer_mul(&tmp, &tmp2, &dest->data.integer);
+      integer_clean(&tmp);
+      integer_clean(&tmp2);
+      return dest;
     case TAG_U32:
-      return tag_init_u64(dest, a->data.u64 * (u64) b->data.u32);
+      integer_init_u64(&tmp, a->data.u64);
+      integer_init_u32(&tmp2, b->data.u32);
+      tag_init_integer_zero(dest);
+      integer_mul(&tmp, &tmp2, &dest->data.integer);
+      integer_clean(&tmp);
+      integer_clean(&tmp2);
+      return dest;
     case TAG_U64:
-      return tag_init_u64(dest, a->data.u64 * b->data.u64);
+      integer_init_u64(&tmp, a->data.u64);
+      integer_init_u64(&tmp2, b->data.u64);
+      tag_init_integer_zero(dest);
+      integer_mul(&tmp, &tmp2, &dest->data.integer);
+      integer_clean(&tmp);
+      integer_clean(&tmp2);
+      return dest;
     default:
       goto ko;
     }
diff --git a/libc3/tag.h b/libc3/tag.h
index 6e9ba04..be3d406 100644
--- a/libc3/tag.h
+++ b/libc3/tag.h
@@ -94,7 +94,7 @@ s_tag *            tag_equal (const s_tag *a, const s_tag *b,
 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);
-bool               tag_ident_is_unbound (const s_tag *tag);
+bool               tag_ident_is_bound (const s_tag *tag);
 bool               tag_is_bound_var (const s_tag *tag);
 bool               tag_is_number (const s_tag *tag);
 bool               tag_is_unbound_var (const s_tag *tag);