keval.c (6207B)
1 /* 2 ** keval.c 3 ** klisp eval function 4 ** See Copyright Notice in klisp.h 5 */ 6 7 #include "klisp.h" 8 #include "kstate.h" 9 #include "kobject.h" 10 #include "kpair.h" 11 #include "kenvironment.h" 12 #include "kcontinuation.h" 13 #include "kerror.h" 14 15 /* for continuation name setting */ 16 #include "kghelpers.h" 17 18 /* Continuations */ 19 void do_eval_ls(klisp_State *K); 20 void do_combine_operator(klisp_State *K); 21 void do_combine_operands(klisp_State *K); 22 23 /* 24 ** Eval helpers 25 */ 26 void do_eval_ls(klisp_State *K) 27 { 28 TValue *xparams = K->next_xparams; 29 TValue obj = K->next_value; 30 klisp_assert(ttisnil(K->next_env)); 31 /* 32 ** xparams[0]: remaining list 33 ** xparams[1]: rem_pairs 34 ** xparams[2]: accumulated list 35 ** xparams[3]: dynamic environment 36 ** xparams[4]: apairs 37 ** xparams[5]: cpairs 38 */ 39 TValue rest = xparams[0]; 40 int32_t rem_pairs = ivalue(xparams[1]); 41 TValue acc = xparams[2]; 42 TValue env = xparams[3]; 43 TValue tv_apairs = xparams[4]; 44 TValue tv_cpairs = xparams[5]; 45 46 acc = kcons(K, obj, acc); 47 krooted_tvs_push(K, acc); 48 49 if (rem_pairs == 0) { 50 /* argument evaluation complete, copy the list and encycle if 51 needed (the list was reversed during evaluation, so it should 52 be reversed first) */ 53 TValue res = 54 reverse_copy_and_encycle(K, acc, ivalue(tv_apairs) + 55 ivalue(tv_cpairs), ivalue(tv_cpairs)); 56 krooted_tvs_pop(K); /* pop acc */ 57 kapply_cc(K, res); 58 } else { 59 /* more arguments need to be evaluated */ 60 /* GC: all objects are rooted at this point */ 61 TValue new_cont = 62 kmake_continuation(K, kget_cc(K), do_eval_ls, 6, kcdr(rest), 63 i2tv(rem_pairs - 1), acc, env, tv_apairs, 64 tv_cpairs); 65 krooted_tvs_pop(K); /* pop acc */ 66 kset_cc(K, new_cont); 67 ktail_eval(K, kcar(rest), env); 68 } 69 } 70 71 void do_combine_operands(klisp_State *K) 72 { 73 TValue *xparams = K->next_xparams; 74 TValue comb = K->next_value; 75 klisp_assert(ttisnil(K->next_env)); 76 /* 77 ** xparams[0]: operand list 78 ** xparams[1]: dynamic environment 79 ** xparams[2]: original_obj_with_si 80 */ 81 TValue operands = xparams[0]; 82 TValue env = xparams[1]; 83 TValue si = xparams[2]; 84 85 switch(ttype(comb)) { 86 case K_TAPPLICATIVE: { 87 if (ttisnil(operands)) { 88 /* no arguments => no evaluation, just call the operative */ 89 /* NOTE: the while is needed because it may be multiply wrapped */ 90 while(ttisapplicative(comb)) 91 comb = tv2app(comb)->underlying; 92 ktail_call_si(K, comb, operands, env, si); 93 } else if (ttispair(operands)) { 94 int32_t pairs, apairs, cpairs; 95 TValue comb_cont = 96 kmake_continuation(K, kget_cc(K), do_combine_operator, 97 3, tv2app(comb)->underlying, env, si); 98 99 krooted_tvs_push(K, comb_cont); 100 /* list is copied reversed to eval right to left and 101 avoid mutation of the structure affecting evaluation; 102 this also allows capturing continuations in the middle of 103 argument evaluation with no additional overhead */ 104 TValue arg_ls = check_copy_list(K, operands, false, 105 &pairs, &cpairs); 106 apairs = pairs - cpairs; 107 krooted_tvs_push(K, arg_ls); 108 TValue els_cont = 109 kmake_continuation(K, comb_cont, do_eval_ls, 6, kcdr(arg_ls), 110 i2tv(pairs - 1), KNIL, env, i2tv(apairs), 111 i2tv(cpairs)); 112 krooted_tvs_pop(K); 113 krooted_tvs_pop(K); 114 115 kset_cc(K, els_cont); 116 ktail_eval(K, kcar(arg_ls), env); 117 } else { 118 klispE_throw_simple(K, "Not a list in applicative combination"); 119 return; 120 } 121 } 122 case K_TOPERATIVE: 123 ktail_call_si(K, comb, operands, env, si); 124 break; 125 default: 126 klispE_throw_simple(K, "Not a combiner in combiner position"); 127 return; 128 } 129 } 130 131 void do_combine_operator(klisp_State *K) 132 { 133 TValue *xparams = K->next_xparams; 134 TValue arguments = K->next_value; 135 klisp_assert(ttisnil(K->next_env)); 136 /* 137 ** xparams[0]: combiner 138 ** xparams[1]: dynamic environment 139 ** xparams[2]: original_obj_with_si 140 */ 141 TValue comb = xparams[0]; 142 TValue env = xparams[1]; 143 TValue si = xparams[2]; 144 145 switch(ttype(comb)) { 146 case K_TAPPLICATIVE: { 147 /* we already know arguments is a list, and we already 148 have a fresh copy, but we need to reverse it anyway, 149 this could be optimized but this case (multiply wrapped 150 applicatives) is pretty rare 151 */ 152 break; 153 } 154 case K_TOPERATIVE: 155 ktail_call_si(K, comb, arguments, env, si); 156 default: /* this can't really happen */ 157 klispE_throw_simple(K, "Not a combiner in combiner position"); 158 return; 159 } 160 } 161 162 /* the underlying function of the eval operative */ 163 void keval_ofn(klisp_State *K) 164 { 165 TValue *xparams = K->next_xparams; 166 TValue ptree = K->next_value; 167 TValue denv = K->next_env; 168 klisp_assert(ttisenvironment(K->next_env)); 169 170 UNUSED(xparams); 171 172 TValue obj = ptree; 173 174 switch(ttype(obj)) { 175 case K_TPAIR: { 176 TValue operator = kcar(obj); 177 TValue operands = kcdr(obj); 178 TValue new_cont = 179 kmake_continuation(K, kget_cc(K), do_combine_operands, 3, 180 operands, denv, ktry_get_si(K, obj)); 181 kset_cc(K, new_cont); 182 ktail_eval(K, operator, denv); 183 break; 184 } 185 case K_TSYMBOL: { 186 TValue res = kget_binding(K, denv, obj); 187 kapply_cc(K, res); 188 break; 189 } 190 default: 191 kapply_cc(K, obj); 192 } 193 } 194 195 /* init continuation names */ 196 /* LOCK: this is done before allowing multiple threads */ 197 void kinit_eval_cont_names(klisp_State *K) 198 { 199 Table *t = tv2table(G(K)->cont_name_table); 200 add_cont_name(K, t, do_eval_ls, "eval-argument-list"); 201 add_cont_name(K, t, do_combine_operator, "eval-combine-operator"); 202 add_cont_name(K, t, do_combine_operands, "eval-combine-operands"); 203 } 204