Commit d3850bfa33591628ca67bac8456426c84cfc6487

Thomas de Grivel 2024-01-23T17:23:32

demo_gl_asan

diff --git a/lib/c3/0.1/gl/object.facts b/lib/c3/0.1/gl/object.facts
index 2d28088..3cf4fb1 100644
--- a/lib/c3/0.1/gl/object.facts
+++ b/lib/c3/0.1/gl/object.facts
@@ -7,3 +7,4 @@ replace {GL.Object, :defstruct, [vertex: (GL.Vertex[]) {},
                                  gl_vao: (U32) 0,
                                  gl_vbo: (U32) 0,
                                  gl_ebo: (U32) 0]}
+replace {GL.Object, :clean, cfn Void "gl_object_clean" (GL.Object)}
diff --git a/lib/c3/0.1/gl/sphere.facts b/lib/c3/0.1/gl/sphere.facts
index 86f9b80..30e03a4 100644
--- a/lib/c3/0.1/gl/sphere.facts
+++ b/lib/c3/0.1/gl/sphere.facts
@@ -4,3 +4,4 @@ replace {GL.Sphere, :is_a, :module}
 replace {GL.Sphere, :defstruct, [object: %GL.Object{},
                                  segments_u: (Uw) 3,
                                  segments_v: (Uw) 2]}
+replace {GL.Sphere, :clean, cfn Void "gl_sphere_clean" (GL.Sphere)}
diff --git a/libc3/env.c b/libc3/env.c
index 6d127e4..6ef829d 100644
--- a/libc3/env.c
+++ b/libc3/env.c
@@ -810,48 +810,6 @@ bool env_eval_void (s_env *env, const void *_, s_tag *dest)
   return true;
 }
 
-s_list ** env_get_struct_type_spec (s_env *env,
-                                    const s_sym *module,
-                                    s_list **dest)
-{
-  s_facts_with_cursor cursor;
-  s_fact *found;
-  s_tag tag_defstruct;
-  s_tag tag_module;
-  s_tag tag_var;
-  s_tag tmp;
-  assert(env);
-  assert(module);
-  assert(dest);
-  tag_init_sym(&tag_defstruct, &g_sym_defstruct);
-  tag_init_sym(&tag_module, module);
-  tag_init_var(&tag_var);
-  if (! env_module_maybe_reload(env, module, &env->facts))
-    return NULL;
-  facts_with(&env->facts, &cursor, (t_facts_spec) {
-      &tag_module, &tag_defstruct, &tag_var, NULL, NULL });
-  found = facts_with_cursor_next(&cursor);
-  if (! found) {
-    facts_with_cursor_clean(&cursor);
-    return NULL;
-  }
-  if (! env_eval_tag(env, found->object, &tmp)) {
-    facts_with_cursor_clean(&cursor);
-    return NULL;
-  }
-  facts_with_cursor_clean(&cursor);
-  if (tmp.type != TAG_LIST ||
-      ! list_is_plist(tmp.data.list)) {
-    warnx("env_get_struct_type_spec: module %s"
-          " has a defstruct that is not a property list",
-          module->str.ptr.pchar);
-    tag_clean(&tmp);
-    return NULL;
-  }
-  *dest = tmp.data.list;
-  return dest;
-}
-
 s_env * env_init (s_env *env, int argc, char **argv)
 {
   s_str path;
@@ -935,6 +893,46 @@ void env_longjmp (s_env *env, jmp_buf *jmp_buf)
   longjmp(*jmp_buf, 1);
 }
 
+bool env_module_is_loading (s_env *env, const s_sym *module)
+{
+  s_facts_cursor cursor;
+  s_tag tag_module;
+  s_tag tag_is_loading;
+  s_tag tag_true;
+  assert(env);
+  assert(module);
+  tag_init_sym(&tag_module, module);
+  tag_init_sym(&tag_is_loading, sym_1("is_loading"));
+  tag_init_bool(&tag_true, true);
+  facts_with_tags(&env->facts, &cursor, &tag_module, &tag_is_loading,
+                  &tag_true);
+  if (facts_cursor_next(&cursor)) {
+    facts_cursor_clean(&cursor);
+    return true;
+  }
+  facts_cursor_clean(&cursor);
+  return false;  
+}
+
+void env_module_is_loading_set (s_env *env, const s_sym *module,
+                                bool is_loading)
+{
+  s_tag tag_module;
+  s_tag tag_is_loading;
+  s_tag tag_true;
+  assert(env);
+  assert(module);
+  tag_init_sym(&tag_module, module);
+  tag_init_sym(&tag_is_loading, sym_1("is_loading"));
+  tag_init_bool(&tag_true, true);
+  if (is_loading)
+    facts_replace_tags(&env->facts, &tag_module, &tag_is_loading,
+                       &tag_true);
+  else
+    facts_remove_fact_tags(&env->facts, &tag_module, &tag_is_loading,
+                           &tag_true);
+}
+
 bool env_module_load (s_env *env, const s_sym *module, s_facts *facts)
 {
   s_str path;
@@ -948,17 +946,21 @@ bool env_module_load (s_env *env, const s_sym *module, s_facts *facts)
   assert(env);
   assert(module);
   assert(facts);
+  if (env_module_is_loading(env, module)) {
+    return true;
+  }
+  env_module_is_loading_set(env, module, true);
   if (! module_path(module, &env->module_path, &path)) {
     warnx("env_module_load: %s: module_path",
           module->str.ptr.pchar);
-    return false;
+    goto ko;
   }
   tag_init_time(&tag_time);
   if (facts_load_file(facts, &path) < 0) {
     warnx("env_module_load: %s: facts_load_file",
           path.ptr.pchar);
     str_clean(&path);
-    return false;
+    goto ko;
   }
   str_clean(&path);
   tag_init_sym(&tag_module_name, module);
@@ -966,16 +968,21 @@ bool env_module_load (s_env *env, const s_sym *module, s_facts *facts)
   facts_replace_tags(facts, &tag_module_name, &tag_load_time,
                      &tag_time);
   tag_clean(&tag_time);
-  if (env_get_struct_type_spec(env, module, &st_spec)) {
+  if (env_struct_type_get_spec(env, module, &st_spec)) {
     tag_init_sym(&tag_struct_type, &g_sym_struct_type);
     tag_st.type = TAG_STRUCT_TYPE;
     st = &tag_st.data.struct_type;
     struct_type_init(st, module, st_spec);
+    st->clean = env_struct_type_get_clean(env, module);
     facts_replace_tags(facts, &tag_module_name, &tag_struct_type,
                        &tag_st);
     list_delete_all(st_spec);
   }
+  env_module_is_loading_set(env, module, false);
   return true;
+ ko:
+  env_module_is_loading_set(env, module, false);
+  return false;
 }
 
 bool env_module_maybe_reload (s_env *env, const s_sym *module,
@@ -1253,6 +1260,93 @@ const s_struct_type * env_struct_type_find (s_env *env,
   return result;
 }
 
+f_clean env_struct_type_get_clean (s_env *env, const s_sym *module)
+{
+  s_facts_with_cursor cursor;
+  s_fact *found;
+  s_tag tag_clean;
+  s_tag tag_module;
+  s_tag tag_var;
+  f_clean tmp;
+  const s_sym *type;
+  tag_init_sym(&tag_module, module);
+  tag_init_sym(&tag_clean, sym_1("clean"));
+  tag_init_var(&tag_var);
+  facts_with(&env->facts, &cursor, (t_facts_spec) {
+      &tag_module, &tag_clean, &tag_var, NULL, NULL });
+  found = facts_with_cursor_next(&cursor);
+  if (! found) {
+    facts_with_cursor_clean(&cursor);
+    return NULL;
+  }
+  if (found->object->type != TAG_CFN) {
+    tag_type(found->object, &type);
+    err_write_1("env_struct_type_get_clean: ");
+    err_inspect_sym(&module);
+    err_write_1(": clean is actually a ");
+    err_inspect_sym(&type);
+    err_write_1(", it should be a Cfn.\n");
+    assert(! "env_struct_type_get_clean: invalid object");
+    facts_with_cursor_clean(&cursor);
+    return NULL;
+  }
+  if (found->object->data.cfn.arity != 1) {
+    err_write_1("env_struct_type_get_clean: ");
+    err_inspect_sym(&module);
+    err_write_1(": clean arity is ");
+    err_inspect_u8(&found->object->data.cfn.arity);
+    err_write_1(", it should be 1.\n");
+    assert(! "env_struct_type_get_clean: invalid arity");
+    facts_with_cursor_clean(&cursor);
+    return NULL;
+  }
+  tmp = (f_clean) found->object->data.cfn.ptr.f;
+  facts_with_cursor_clean(&cursor);
+  return tmp;
+}
+
+s_list ** env_struct_type_get_spec (s_env *env,
+                                    const s_sym *module,
+                                    s_list **dest)
+{
+  s_facts_with_cursor cursor;
+  s_fact *found;
+  s_tag tag_defstruct;
+  s_tag tag_module;
+  s_tag tag_var;
+  s_tag tmp;
+  assert(env);
+  assert(module);
+  assert(dest);
+  tag_init_sym(&tag_defstruct, &g_sym_defstruct);
+  tag_init_sym(&tag_module, module);
+  tag_init_var(&tag_var);
+  if (! env_module_maybe_reload(env, module, &env->facts))
+    return NULL;
+  facts_with(&env->facts, &cursor, (t_facts_spec) {
+      &tag_module, &tag_defstruct, &tag_var, NULL, NULL });
+  found = facts_with_cursor_next(&cursor);
+  if (! found) {
+    facts_with_cursor_clean(&cursor);
+    return NULL;
+  }
+  if (! env_eval_tag(env, found->object, &tmp)) {
+    facts_with_cursor_clean(&cursor);
+    return NULL;
+  }
+  facts_with_cursor_clean(&cursor);
+  if (tmp.type != TAG_LIST ||
+      ! list_is_plist(tmp.data.list)) {
+    warnx("env_get_struct_type_spec: module %s"
+          " has a defstruct that is not a property list",
+          module->str.ptr.pchar);
+    tag_clean(&tmp);
+    return NULL;
+  }
+  *dest = tmp.data.list;
+  return dest;
+}
+
 bool env_tag_ident_is_bound (const s_env *env, const s_tag *tag,
                              s_facts *facts)
 {
diff --git a/libc3/env.h b/libc3/env.h
index 377daa0..4e13a06 100644
--- a/libc3/env.h
+++ b/libc3/env.h
@@ -64,8 +64,10 @@ bool          env_eval_tag (s_env *env, const s_tag *tag,
 bool          env_eval_tuple (s_env *env, const s_tuple *tuple,
                               s_tag *dest);
 bool          env_eval_void (s_env *env, const void *_, s_tag *dest);
-s_list **     env_get_struct_type_spec (s_env *env, const s_sym *module,
-                                        s_list **dest);
+bool          env_module_is_loading (s_env *env, const s_sym *module);
+void          env_module_is_loading_set (s_env *env,
+                                         const s_sym *module,
+                                         bool value);
 bool          env_module_load (s_env *env, const s_sym *module,
                                s_facts *facts);
 bool          env_module_maybe_reload (s_env *env,
@@ -85,6 +87,10 @@ bool          env_struct_type_exists (s_env *env,
                                         const s_sym *module);
 const s_struct_type *
               env_struct_type_find (s_env *env, const s_sym *module);
+f_clean       env_struct_type_get_clean (s_env *env,
+                                         const s_sym *module);
+s_list **     env_struct_type_get_spec (s_env *env, const s_sym *module,
+                                        s_list **dest);
 bool          env_tag_ident_is_bound (const s_env *env,
                                       const s_tag *tag,
                                       s_facts *facts);
diff --git a/libc3/facts.c b/libc3/facts.c
index 9cc3304..e41ae7b 100644
--- a/libc3/facts.c
+++ b/libc3/facts.c
@@ -608,6 +608,20 @@ bool facts_remove_fact (s_facts *facts, const s_fact *fact)
   return result;
 }
 
+bool facts_remove_fact_tags (s_facts *facts, const s_tag *subject,
+                             const s_tag *predicate,
+                             const s_tag *object)
+{
+  s_fact fact;
+  assert(facts);
+  assert(subject);
+  assert(predicate);
+  assert(object);
+  fact.subject = subject;
+  fact.predicate = predicate;
+  fact.object = object;
+  return facts_remove_fact(facts, &fact);
+}
 
 s_fact * facts_replace_fact (s_facts *facts, const s_fact *fact)
 {
diff --git a/libc3/facts.h b/libc3/facts.h
index e76695e..9603dad 100644
--- a/libc3/facts.h
+++ b/libc3/facts.h
@@ -46,6 +46,9 @@ void     facts_lock_w (s_facts *facts);
 sw       facts_open_file (s_facts *facts, const s_str *path);
 s_tag *  facts_ref_tag (s_facts *facts, const s_tag *tag);
 bool     facts_remove_fact (s_facts *facts, const s_fact *fact);
+bool     facts_remove_fact_tags (s_facts *facts, const s_tag *subject,
+                                 const s_tag *predicate,
+                                 const s_tag *object);
 void     facts_remove_all (s_facts *facts);
 s_fact * facts_replace_fact (s_facts *facts, const s_fact *fact);
 s_fact * facts_replace_tags (s_facts *facts, const s_tag *subject,
diff --git a/libc3/struct.c b/libc3/struct.c
index 7f0463f..5945313 100644
--- a/libc3/struct.c
+++ b/libc3/struct.c
@@ -48,7 +48,9 @@ void struct_clean (s_struct *s)
   assert(s);
   assert(s->type);
   if (s->data) {
-    if (s->type->must_clean) {
+    if (s->type->clean)
+      s->type->clean(s->data);
+    else if (s->type->must_clean) {
       i = 0;
       while (i < s->type->map.count) {
         if (tag_type(s->type->map.value + i, &sym))
diff --git a/libc3/struct_type.c b/libc3/struct_type.c
index 0510f4f..8aa15f1 100644
--- a/libc3/struct_type.c
+++ b/libc3/struct_type.c
@@ -142,7 +142,7 @@ s_struct_type * struct_type_init_from_env (s_struct_type *st,
   assert(st);
   assert(module);
   assert(env);
-  if (! env_get_struct_type_spec(env, module, &spec) ||
+  if (! env_struct_type_get_spec(env, module, &spec) ||
       ! spec)
     return NULL;
   if (! struct_type_init(st, module, spec))
diff --git a/libc3/types.h b/libc3/types.h
index ca47f11..7384bbe 100644
--- a/libc3/types.h
+++ b/libc3/types.h
@@ -185,6 +185,7 @@ typedef const s_tag *p_tag;
 typedef u64          t_skiplist_height;
 
 /* function typedefs */
+typedef void (* f_clean) (void *x);
 typedef bool (* f_sequence) (s_sequence *seq);
 typedef bool (* f_sequence_button) (s_sequence *seq, u8 button, sw x,
                                     sw y);
@@ -337,6 +338,7 @@ struct struct_type {
   bool must_clean;
   uw *offset;
   uw size;
+  f_clean clean;
 };
 
 /* 3 */
diff --git a/libc3/window/cairo/demo/flies.c b/libc3/window/cairo/demo/flies.c
index 9f9790c..170b5ad 100644
--- a/libc3/window/cairo/demo/flies.c
+++ b/libc3/window/cairo/demo/flies.c
@@ -70,7 +70,7 @@ bool flies_load (s_sequence *seq)
   tag_init_sym(map->key + 3, sym_1("t"));
   tag_init_uw( map->value + 3, 0);
   board = &map->value[0].data.array;
-  board->data = malloc(board->size);
+  array_allocate(board);
   i = 0;
   while (i < BOARD_SIZE) {
     address[0] = i;
diff --git a/libc3/window/sdl2/demo/flies.c b/libc3/window/sdl2/demo/flies.c
index e115b53..aa23be9 100644
--- a/libc3/window/sdl2/demo/flies.c
+++ b/libc3/window/sdl2/demo/flies.c
@@ -75,7 +75,7 @@ bool flies_load (s_sequence *seq)
   tag_init_sym(    map->key + 3, sym_1("t"));
   tag_init_uw(   map->value + 3, 0);
   board = &map->value[0].data.array;
-  board->data = malloc(board->size);
+  array_allocate(board);
   i = 0;
   while (i < BOARD_SIZE) {
     address[0] = i;