kgeqp.c (1539B)
1 /* 2 ** kgeqp.c 3 ** Equivalence under mutation features for the ground environment 4 ** See Copyright Notice in klisp.h 5 */ 6 7 #include <assert.h> 8 #include <stdio.h> 9 #include <stdlib.h> 10 #include <stdbool.h> 11 #include <stdint.h> 12 13 #include "kstate.h" 14 #include "kobject.h" 15 #include "kpair.h" 16 #include "kcontinuation.h" 17 #include "kerror.h" 18 19 #include "kghelpers.h" 20 #include "kgeqp.h" 21 22 /* 4.2.1 eq? */ 23 /* 6.5.1 eq? */ 24 /* NOTE: this does 2 passes but could do it in one */ 25 void eqp(klisp_State *K) 26 { 27 TValue *xparams = K->next_xparams; 28 TValue ptree = K->next_value; 29 TValue denv = K->next_env; 30 klisp_assert(ttisenvironment(K->next_env)); 31 UNUSED(denv); 32 UNUSED(xparams); 33 34 int32_t pairs; 35 check_list(K, true, ptree, &pairs, NULL); 36 37 /* In this case we can get away without comparing the 38 first and last element on a cycle because eq? is 39 symetric, (cf: ftyped_bpred) */ 40 int32_t comps = pairs - 1; 41 TValue tail = ptree; 42 TValue res = KTRUE; 43 while(comps-- > 0) { /* comps could be -1 if ptree is nil */ 44 TValue first = kcar(tail); 45 tail = kcdr(tail); /* tail only advances one place per iteration */ 46 TValue second = kcar(tail); 47 48 if (!eq2p(K, first, second)) { 49 res = KFALSE; 50 break; 51 } 52 } 53 54 kapply_cc(K, res); 55 } 56 57 /* init ground */ 58 void kinit_eqp_ground_env(klisp_State *K) 59 { 60 TValue ground_env = G(K)->ground_env; 61 TValue symbol, value; 62 /* 4.2.1 eq? */ 63 /* 6.5.1 eq? */ 64 add_applicative(K, ground_env, "eq?", eqp, 0); 65 }