Commit 8021d329d88c073d91caddd3daf189606632eb31

Thomas de Grivel 2023-08-07T23:05:31

wip

diff --git a/Makefile b/Makefile
index 3df9cfc..d474610 100644
--- a/Makefile
+++ b/Makefile
@@ -62,7 +62,7 @@ clean_cov:
 	${MAKE} -C test clean_cov
 
 debug:
-	${GMAKE} -C libffi debug
+	${GMAKE} -C libffi all
 	${MAKE} -C libtommath debug
 	${MAKE} -C libc3 debug
 	${MAKE} -C ic3 debug
diff --git a/README.md b/README.md
index f4f07d0..ab1ebf2 100644
--- a/README.md
+++ b/README.md
@@ -86,8 +86,9 @@ Script interpreter.
      - DONE triple serial id
    - math
      - floating point numbers
-   - boolean operators
-   - comparison operators
+   - variables
+   - DONE boolean operators
+   - DONE comparison operators
    - arrays
    - lists
    - defmodule
diff --git a/lib/c3/0.1/c3.facts b/lib/c3/0.1/c3.facts
index b9c8eda..250403b 100644
--- a/lib/c3/0.1/c3.facts
+++ b/lib/c3/0.1/c3.facts
@@ -11,6 +11,7 @@ add {C3, :symbol, C3.-}
 add {C3, :symbol, C3./}
 add {C3, :symbol, C3.<=}
 add {C3, :symbol, C3.<}
+add {C3, :symbol, C3.=}
 add {C3, :symbol, C3.==}
 add {C3, :symbol, C3.>=}
 add {C3, :symbol, C3.>}
@@ -49,6 +50,11 @@ 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 :tag "tag_equal" (:tag, :tag, :&result)}
+add {C3.=, :is_a, :operator}
+add {C3.=, :operator_precedence, 5}
+add {C3.=, :operator_associativity, :left}
 add {C3.==, :arity, 2}
 add {C3.==, :cfn, cfn :bool "tag_eq" (:tag, :tag)}
 add {C3.==, :is_a, :operator}
diff --git a/libc3/binding.c b/libc3/binding.c
index e446b55..6330bd1 100644
--- a/libc3/binding.c
+++ b/libc3/binding.c
@@ -31,7 +31,7 @@ void binding_delete_all (s_binding *binding)
   }
 }
 
-const s_tag * binding_get (s_binding *binding, const s_sym *name)
+const s_tag * binding_get (const s_binding *binding, const s_sym *name)
 {
   while (binding) {
     if (binding->name == name)
diff --git a/libc3/binding.h b/libc3/binding.h
index 7fc6411..d35a4cc 100644
--- a/libc3/binding.h
+++ b/libc3/binding.h
@@ -29,6 +29,8 @@ void binding_delete (s_binding *binding);
 void binding_delete_all (s_binding *binding);
 
 /* observers */
-const s_tag * binding_get (s_binding *binding, const s_sym *name);
+const s_tag * binding_get (const s_binding *binding, const s_sym *name);
+const s_tag * binding_is_bound (const s_binding *binding,
+                                const s_sym *name);
 
 #endif /* BINDING_H */
diff --git a/libc3/buf_inspect.c b/libc3/buf_inspect.c
index aaf9b21..1ead071 100644
--- a/libc3/buf_inspect.c
+++ b/libc3/buf_inspect.c
@@ -418,9 +418,21 @@ sw buf_inspect_cfn (s_buf *buf, const s_cfn *cfn)
   sw r;
   sw result = 0;
   assert(cfn);
+  if ((r = buf_write_1(buf, "cfn ")) < 0)
+    return r;
+  result += r;
+  if ((r = buf_inspect_sym(buf, cfn->result_type)) < 0)
+    return r;
+  result += r;
+  if ((r = buf_write_1(buf, " ")) < 0)
+    return r;
+  result += r;
   if ((r = buf_inspect_str(buf, &cfn->name->str)) < 0)
     return r;
   result += r;
+  if ((r = buf_write_1(buf, " ")) < 0)
+    return r;
+  result += r;
   if ((r = buf_write_1(buf, "(")) < 0)
     return r;
   result += r;
@@ -428,6 +440,7 @@ sw buf_inspect_cfn (s_buf *buf, const s_cfn *cfn)
   while (arg_type) {
     if ((r = buf_inspect_tag(buf, &arg_type->tag)) < 0)
       return r;
+    result += r;
     arg_type = list_next(arg_type);
     if (arg_type) {
       if ((r = buf_write_1(buf, ", ")) < 0)
diff --git a/libc3/env.c b/libc3/env.c
index 453ebc1..0658af0 100644
--- a/libc3/env.c
+++ b/libc3/env.c
@@ -293,14 +293,17 @@ bool env_eval_equal_tag (s_env *env, const s_tag *a, const s_tag *b,
   assert(a);
   assert(b);
   assert(dest);
-  if (a->type == TAG_IDENT) {
-    if (b->type == TAG_IDENT)
-      warnx("TAG_IDENT = TAG_IDENT");
+  if (a->type == TAG_IDENT && tag_ident_is_unbound(a) &&
+      b->type == TAG_IDENT && tag_ident_is_unbound(b)) {
+    warnx("TAG_IDENT = TAG_IDENT");
+    return false;
+  }
+  if (a->type == TAG_IDENT && tag_ident_is_unbound(a)) {
     tag_copy(b, dest);
-    frame_binding_new(env->frame, a->data.ident.sym, b);
+    frame_binding_new(env->frame, b->data.ident.sym, a);
     return true;
   }
-  if (b->type == TAG_IDENT) {
+  if (b->type == TAG_IDENT && tag_ident_is_unbound(b)) {
     tag_copy(a, dest);
     frame_binding_new(env->frame, b->data.ident.sym, a);
     return true;
@@ -323,11 +326,12 @@ bool env_eval_equal_tag (s_env *env, const s_tag *a, const s_tag *b,
     dest->type = TAG_TUPLE;
     return env_eval_equal_tuple(env, &a->data.tuple, &b->data.tuple,
                                 &dest->data.tuple);
-  case TAG_ARRAY:
-  case TAG_BOOL:
   case TAG_CALL:
   case TAG_CALL_FN:
   case TAG_CALL_MACRO:
+  case TAG_QUOTE:
+  case TAG_ARRAY:
+  case TAG_BOOL:
   case TAG_CFN:
   case TAG_CHARACTER:
   case TAG_F32:
@@ -335,7 +339,6 @@ bool env_eval_equal_tag (s_env *env, const s_tag *a, const s_tag *b,
   case TAG_FN:
   case TAG_INTEGER:
   case TAG_PTAG:
-  case TAG_QUOTE:
   case TAG_S16:
   case TAG_S32:
   case TAG_S64:
@@ -385,12 +388,14 @@ bool env_eval_equal_tuple (s_env *env, const s_tuple *a,
 bool env_eval_ident (s_env *env, const s_ident *ident, s_tag *dest)
 {
   const s_tag *tag;
+  s_tag tmp;
   assert(env);
   assert(ident);
-  if (! (tag = frame_get(env->frame, ident->sym))) {
-    assert(! "env_eval_ident: unbound variable");
-    errx(1, "env_eval_ident: %s: unbound variable",
-         ident->sym->str.ptr.ps8);
+  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;
   }
   tag_copy(tag, dest);
   return true;
@@ -464,7 +469,7 @@ s_env * env_init (s_env *env)
 {
   assert(env);
   env->error_handler = NULL;
-  env->frame = NULL;
+  env->frame = frame_new(NULL);
   buf_init_alloc(&env->in, BUF_SIZE);
   buf_file_open_r(&env->in, stdin);
   buf_init_alloc(&env->out, BUF_SIZE);
diff --git a/libc3/frame.c b/libc3/frame.c
index ed41fe3..0a8a944 100644
--- a/libc3/frame.c
+++ b/libc3/frame.c
@@ -48,7 +48,7 @@ void frame_delete_all (s_frame *frame)
     frame = frame_delete(frame);
 }
 
-const s_tag * frame_get (s_frame *frame, const s_sym *sym)
+const s_tag * frame_get (const s_frame *frame, const s_sym *sym)
 {
   const s_tag *tag;
   while (frame) {
diff --git a/libc3/frame.h b/libc3/frame.h
index fcc25d9..b7e0871 100644
--- a/libc3/frame.h
+++ b/libc3/frame.h
@@ -31,6 +31,6 @@ void frame_binding_new(s_frame *frame, const s_sym *name,
                        const s_tag *value);
 
 /* observers */
-const s_tag * frame_get (s_frame *frame, const s_sym *sym);
+const s_tag * frame_get (const s_frame *frame, const s_sym *sym);
 
 #endif /* FRAME_H */
diff --git a/libc3/module.c b/libc3/module.c
index e69ee0c..ddbf71b 100644
--- a/libc3/module.c
+++ b/libc3/module.c
@@ -14,6 +14,51 @@
 #include <string.h>
 #include "c3.h"
 
+s_tag * module_get (const s_module *module, const s_sym *sym,
+                    s_tag *dest)
+{
+  s_ident ident;
+  s_tag tag_cfn;
+  s_tag tag_fn;
+  s_tag tag_ident;
+  s_tag tag_is_a;
+  s_tag tag_module;
+  s_tag tag_name;
+  s_tag tag_symbol;
+  s_tag tag_tmp;
+  assert(module);
+  assert(sym);
+  s_facts_with_cursor cursor;
+  tag_init_sym(&tag_name, module->name);
+  tag_init_1(  &tag_is_a, ":is_a");
+  tag_init_1(  &tag_module, ":module");
+  tag_init_1(  &tag_symbol, ":symbol");
+  ident_init(&ident, sym);
+  ident.module_name = module->name;
+  tag_init_ident(&tag_ident, &ident);
+  facts_with(module->facts, &cursor, (t_facts_spec) {
+      &tag_name, &tag_is_a, &tag_module,
+      &tag_symbol, &tag_ident, NULL, NULL});
+  if (! facts_with_cursor_next(&cursor))
+    return NULL;
+  facts_with_cursor_clean(&cursor);
+  tag_init_1(&tag_cfn, ":cfn");
+  tag_init_1(&tag_fn, ":fn");
+  tag_init_var(&tag_tmp);
+  facts_with(module->facts, &cursor, (t_facts_spec) {
+      &tag_ident, &tag_cfn, &tag_tmp, NULL, NULL});
+  if (! facts_with_cursor_next(&cursor)) {
+    facts_with_cursor_clean(&cursor);
+    facts_with(module->facts, &cursor, (t_facts_spec) {
+        &tag_ident, &tag_fn, &tag_tmp, NULL, NULL});
+    if (! facts_with_cursor_next(&cursor))
+      tag_init_void(&tag_tmp);
+  }
+  facts_with_cursor_clean(&cursor);
+  *dest = tag_tmp;
+  return dest;
+}
+
 s_module * module_load (s_module *module, const s_sym *name,
                         s_facts *facts)
 {
diff --git a/libc3/module.h b/libc3/module.h
index ef19e9c..228d65b 100644
--- a/libc3/module.h
+++ b/libc3/module.h
@@ -29,4 +29,10 @@ s_str *    module_name_path (const s_str *prefix, const s_sym *name,
 sw         module_name_path_size (const s_str *prefix,
                                   const s_sym *name);
 
+/* Observers */
+s_tag * module_get (const s_module *module, const s_sym *sym,
+                    s_tag *dest);
+s_tag * module_is_bound (const s_module *module, const s_sym *sym,
+                         s_tag *dest);
+
 #endif /* MODULE_H */
diff --git a/libc3/tag.c b/libc3/tag.c
index eddc5e7..fbfc156 100644
--- a/libc3/tag.c
+++ b/libc3/tag.c
@@ -16,6 +16,7 @@
 #include <string.h>
 #include <strings.h>
 #include "c3.h"
+#include "frame.h"
 
 s_tag g_tag_first;
 s_tag g_tag_last;
@@ -1015,6 +1016,16 @@ bool tag_eq (const s_tag *a, const s_tag *b)
   return compare_tag(a, b) == 0;
 }
 
+s_tag * tag_equal (const s_tag *a, const s_tag *b, s_tag *dest)
+{
+  assert(a);
+  assert(b);
+  assert(dest);
+  if (! env_eval_equal_tag (&g_c3_env, a, b, dest))
+    return NULL;
+  return dest;
+}
+
 s_tag * tag_f32 (s_tag *tag, f32 x)
 {
   assert(tag);
@@ -1071,6 +1082,17 @@ 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)
+{
+  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));
+}
+
 s_tag * tag_init (s_tag *tag)
 {
   bzero(tag, sizeof(s_tag));
@@ -1430,13 +1452,13 @@ s_tag * tag_integer_reduce (s_tag *tag)
   return tag;
 }
 
-e_bool tag_is_bound_var (const s_tag *tag)
+bool tag_is_bound_var (const s_tag *tag)
 {
   return (tag &&
           tag->type != TAG_VAR);
 }
 
-e_bool tag_is_number (const s_tag *tag)
+bool tag_is_number (const s_tag *tag)
 {
   assert(tag);
   switch (tag->type) {
@@ -1455,7 +1477,7 @@ e_bool tag_is_number (const s_tag *tag)
   return false;
 }
 
-e_bool tag_is_unbound_var (const s_tag *tag)
+bool tag_is_unbound_var (const s_tag *tag)
 {
   return (tag &&
           tag->type == TAG_VAR);
diff --git a/libc3/tag.h b/libc3/tag.h
index 19af629..6e9ba04 100644
--- a/libc3/tag.h
+++ b/libc3/tag.h
@@ -89,12 +89,15 @@ s_tag * tag_new_var ();
 void tag_delete (s_tag *tag);
 
 /* Observers */
+s_tag *            tag_equal (const s_tag *a, const s_tag *b,
+                              s_tag *dest);
 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);
-e_bool             tag_is_bound_var (const s_tag *tag);
-e_bool             tag_is_number (const s_tag *tag);
-e_bool             tag_is_unbound_var (const s_tag *tag);
+bool               tag_ident_is_unbound (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);
 s8                 tag_number_compare (const s_tag *a, const s_tag *b);
 s_tag *            tag_paren (const s_tag *tag, s_tag *dest);
 sw                 tag_size (const s_tag *tag);