Commit 39d65584e0db11021ec3ecb474493070279e06d6
2023-08-08T14:21:00
special operators
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151
diff --git a/lib/c3/0.1/c3.facts b/lib/c3/0.1/c3.facts
index 250403b..92e8f31 100644
--- a/lib/c3/0.1/c3.facts
+++ b/lib/c3/0.1/c3.facts
@@ -53,6 +53,7 @@ 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.=, :is_a, :special_operator}
add {C3.=, :operator_precedence, 5}
add {C3.=, :operator_associativity, :left}
add {C3.==, :arity, 2}
diff --git a/libc3/env.c b/libc3/env.c
index c41467e..cb56321 100644
--- a/libc3/env.c
+++ b/libc3/env.c
@@ -83,6 +83,7 @@ bool env_eval_call (s_env *env, const s_call *call, s_tag *dest)
s_tag tag_macro;
s_tag tag_module;
s_tag tag_module_name;
+ s_tag tag_special_operator;
s_tag tag_sym;
s_tag tag_symbol;
s_tag tag_var;
@@ -98,6 +99,7 @@ bool env_eval_call (s_env *env, const s_call *call, s_tag *dest)
tag_init_1( &tag_macro, ":macro");
tag_init_1( &tag_module, ":module");
tag_init_sym( &tag_module_name, c.ident.module_name);
+ tag_init_1( &tag_special_operator, ":special_operator");
tag_init_sym( &tag_sym, call->ident.sym);
tag_init_1( &tag_symbol, ":symbol");
tag_init_var( &tag_var);
@@ -137,8 +139,15 @@ bool env_eval_call (s_env *env, const s_call *call, s_tag *dest)
&tag_ident, &tag_is_a, &tag_macro, NULL, NULL });
if (facts_with_cursor_next(&cursor))
result = env_eval_call_macro(env, &c, dest);
- else
- result = env_eval_call_fn(env, &c, dest);
+ else {
+ facts_with_cursor_clean(&cursor);
+ facts_with(&env->facts, &cursor, (t_facts_spec) {
+ &tag_ident, &tag_is_a, &tag_special_operator, NULL, NULL});
+ if (facts_with_cursor_next(&cursor))
+ result = env_eval_call_special_operator(env, &c, dest);
+ else
+ result = env_eval_call_fn(env, &c, dest);
+ }
facts_with_cursor_clean(&cursor);
call_clean(&c);
return result;
@@ -247,6 +256,42 @@ bool env_eval_call_macro (s_env *env, const s_call *call, s_tag *dest)
return false;
}
+bool env_eval_call_special_operator (s_env *env, const s_call *call,
+ s_tag *dest)
+{
+ s_frame frame;
+ s_fn *fn;
+ s_tag tag;
+ s_list *tmp = NULL;
+ assert(env);
+ assert(call);
+ assert(dest);
+ if (call->cfn)
+ return cfn_apply(call->cfn, call->arguments, dest) != NULL;
+ fn = call->fn;
+ assert(fn);
+ frame_init(&frame, env->frame);
+ env->frame = &frame;
+ if (! env_eval_equal_list(env, fn->pattern, call->arguments, &tmp)) {
+ err_puts("env_eval_call_fn: no clause matching.\nTried clauses :\n");
+ err_inspect_list(fn->pattern);
+ err_puts("\nArguments :\n");
+ err_inspect_list(call->arguments);
+ err_puts("\n");
+ env->frame = frame_clean(&frame);
+ return false;
+ }
+ if (! env_eval_progn(env, fn->algo, &tag)) {
+ list_delete_all(tmp);
+ env->frame = frame_clean(&frame);
+ return false;
+ }
+ *dest = tag;
+ list_delete_all(tmp);
+ env->frame = frame_clean(&frame);
+ return true;
+}
+
bool env_eval_equal_list (s_env *env, const s_list *a, const s_list *b,
s_list **dest)
{
@@ -289,21 +334,39 @@ 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;
+ s_tag tmp_a;
+ s_tag tmp_b;
assert(env);
assert(a);
assert(b);
assert(dest);
- if (a->type == TAG_IDENT && tag_ident_is_unbound(a) &&
- b->type == TAG_IDENT && tag_ident_is_unbound(b)) {
+ 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");
return false;
}
- if (a->type == TAG_IDENT) {
+ if (type_a == TAG_CALL) {
+ if (! env_eval_call(env, &a->data.call, &tmp_a))
+ return false;
+ a = &tmp_a;
+ }
+ if (type_b == TAG_CALL) {
+ if (! env_eval_call(env, &b->data.call, &tmp_b))
+ return false;
+ b = &tmp_b;
+ }
+ if (type_a == TAG_IDENT) {
tag_copy(b, dest);
frame_binding_new(env->frame, a->data.ident.sym, dest);
return true;
}
- if (b->type == TAG_IDENT) {
+ if (type_b == TAG_IDENT) {
tag_copy(a, dest);
frame_binding_new(env->frame, b->data.ident.sym, dest);
return true;
diff --git a/libc3/env.h b/libc3/env.h
index 618fd8a..b9fce6e 100644
--- a/libc3/env.h
+++ b/libc3/env.h
@@ -30,6 +30,9 @@ bool env_eval_call_fn (s_env *env, const s_call *call,
s_tag *dest);
bool env_eval_call_macro (s_env *env, const s_call *call,
s_tag *dest);
+bool env_eval_call_special_operator (s_env *env,
+ const s_call *call,
+ s_tag *dest);
bool env_eval_equal_list (s_env *env, const s_list *a,
const s_list *b, s_list **dest);
bool env_eval_equal_tag (s_env *env, const s_tag *a,