kgtables.c (10420B)
1 /* 2 ** kgtables.c 3 ** Hash table interface for the ground environment 4 ** See Copyright Notice in klisp.h 5 */ 6 7 #include <assert.h> 8 #include <stdio.h> 9 #include <string.h> 10 #include <stdlib.h> 11 #include <stdbool.h> 12 #include <stdint.h> 13 14 #include "kstate.h" 15 #include "kobject.h" 16 #include "kapplicative.h" 17 #include "koperative.h" 18 #include "kcontinuation.h" 19 #include "kerror.h" 20 #include "kpair.h" 21 22 #include "kghelpers.h" 23 #include "kgtables.h" 24 25 /* Provide lisp interface to internal hash tables. The interface 26 * is modeled after SRFI-69. 27 * 28 * MISSING FUNCTIONALITY 29 * - no user definable equivalence predicates 30 * - no user definable hash functions 31 * - hash function itself is not available 32 * - hash-table-ref/default not implemented 33 * - hash-table-update! not implemented 34 * - hash-table-for-each (hash-table-walk in SRFI-69) not implemented 35 * 36 * DEVIATIONS FROM SRFI-69 37 * - hash-table-size renamed to hash-table-length to match klisp's vector-length 38 * - hash-table-exists? and hash-table-delete! accept more than one key 39 * - hash-table-merge! accepts more than two arguments 40 * 41 * KNOWN BUGS 42 * - removing elements do not cause hash tables shrink 43 * - hash_table_merge() may compute too low initial table size 44 * - "array" optimization never used 45 * 46 * Hash tables are equal? if and only if they are eq?. Hash 47 * tables do not have external representation. 48 * 49 * BASIC OPERATIONS 50 * 51 * (hash-table? OBJECT...) 52 * Type predicate. Evaluates to #t iff all arguments are hash 53 * tables, and #f otherwise. 54 * 55 * (make-hash-table) 56 * Create new, empty hash table. Currently accepts no optional 57 * parameters (SRFI-69 allows user-defined hash function, etc.) 58 * 59 * (hash-table-set! TABLE KEY VALUE) 60 * Set KEY => VALUE in TABLE, silently replacing 61 * any existing binding. The result is #inert. 62 * 63 * (hash-table-ref TABLE KEY [THUNK]) 64 * Returns value corresponding to KEY in TABLE, if present. 65 * If KEY is not bound and THUNK is given, returns result of 66 * evaluation of (THUNK) in the dynamic environment. Otherwise, 67 * an error is signalled. 68 * 69 * (hash-table-exists? TABLE KEY1 KEY2 ...) 70 * Returns #t if all keys KEY1, KEY2, ... are bound in TABLE. 71 * Returns #f otherwise. 72 * 73 * (hash-table-delete! TABLE KEY1 KEY2 ...) 74 * Removes binding of KEY1, KEY2, ... from TABLE. If keys are not 75 * present, nothing happens. The result is #inert. 76 * 77 * (hash-table-length TABLE) 78 * Returns number of KEY => VALUE bindings in TABLE. 79 * 80 * (hash-table-copy TABLE) 81 * Returns a copy of TABLE. 82 * 83 * (hash-table-merge T1 T2 ... Tn) 84 * Creates new hash table with all bindings from T1, T2, ... Tn. 85 * If more than one of the tables bind the same key, only the 86 * value from the table which is comes last in the argument 87 * list is preserved. 88 * 89 * (hash-table-merge! DEST T1 T2 ... Tn) 90 * Copy all bindings from T1, T2, ... Tn to DEST. If more than 91 * one of the tables bind the same key, only the value from the 92 * table which is comes last in the argument list is preserved. 93 * The result is #inert. 94 * 95 * HIGH-LEVEL CONSTRUCTORS 96 * 97 * (hash-table K1 V1 K2 V2 ...) 98 * Creates new hash table, binding Kn => Vn. If Ki = Kj for i < j, 99 * then Vj overrides Vi. 100 * 101 * (alist->hash-table ALIST) 102 * Creates new hash table from association list. 103 * 104 * WHOLE CONTENTS MANIPULATION 105 * 106 * (hash-table->alist TABLE) 107 * Returns list (KEY . VALUE) pairs from TABLE. 108 * 109 * (hash-table-keys TABLE) 110 * Returns list of all keys from TABLE. 111 * 112 * (hash-table-values TABLE) 113 * Returns list of all values from TABLE. 114 * 115 */ 116 117 static void make_hash_table(klisp_State *K) 118 { 119 check_0p(K, K->next_value); 120 TValue tab = klispH_new(K, 121 0, /* narray - not used in klisp */ 122 32, /* nhash - size of the hash table */ 123 0 /* wflags - no weak pointers */ ); 124 kapply_cc(K, tab); 125 } 126 127 static void hash_table_setB(klisp_State *K) 128 { 129 bind_3tp(K, K->next_value, 130 "hash table", ttistable, tab, 131 "any", anytype, key, 132 "any", anytype, val); 133 *klispH_set(K, tv2table(tab), key) = val; 134 kapply_cc(K, KINERT); 135 } 136 137 static void hash_table_ref(klisp_State *K) 138 { 139 bind_al2tp(K, K->next_value, 140 "hash table", ttistable, tab, 141 "any", anytype, key, 142 dfl); 143 (void) get_opt_tpar(K, dfl, "combiner", ttiscombiner); 144 145 const TValue *node = klispH_get(tv2table(tab), key); 146 if (!ttisfree(*node)) { 147 kapply_cc(K, *node); 148 } else if (ttiscombiner(dfl)) { 149 while(ttisapplicative(dfl)) 150 dfl = tv2app(dfl)->underlying; 151 ktail_call(K, dfl, KNIL, K->next_env); 152 } else { 153 klispE_throw_simple_with_irritants(K, "key not found", 154 1, key); 155 } 156 } 157 158 static void hash_table_existsP(klisp_State *K) 159 { 160 int32_t i, pairs; 161 TValue res = KTRUE; 162 bind_al1tp(K, K->next_value, 163 "hash table", ttistable, tab, 164 keys); 165 check_list(K, 1, keys, &pairs, NULL); 166 167 for (i = 0; i < pairs; i++, keys = kcdr(keys)) { 168 const TValue *node = klispH_get(tv2table(tab), kcar(keys)); 169 if (ttisfree(*node)) { 170 res = KFALSE; 171 break; 172 } 173 } 174 kapply_cc(K, res); 175 } 176 177 static void hash_table_deleteB(klisp_State *K) 178 { 179 int32_t i, pairs; 180 bind_al1tp(K, K->next_value, 181 "hash table", ttistable, tab, 182 keys); 183 check_list(K, 1, keys, &pairs, NULL); 184 185 for (i = 0; i < pairs; i++, keys = kcdr(keys)) { 186 TValue *node = klispH_set(K, tv2table(tab), kcar(keys)); 187 if (!ttisfree(*node)) { 188 *node = KFREE; /* TODO: shrink ? */ 189 } 190 } 191 kapply_cc(K, KINERT); 192 } 193 194 static void hash_table_length(klisp_State *K) 195 { 196 bind_1tp(K, K->next_value, "hash table", ttistable, tab); 197 kapply_cc(K, i2tv(klispH_numuse(tv2table(tab)))); 198 } 199 200 static void hash_table_constructor(klisp_State *K) 201 { 202 int32_t pairs, cpairs, i; 203 TValue rest = K->next_value; 204 check_list(K, 1, rest, &pairs, &cpairs); 205 if ((pairs % 2 != 0) || (cpairs % 2 != 0)) 206 klispE_throw_simple(K, "expected even number of arguments"); 207 208 TValue tab = klispH_new(K, 0, 32 + 2 * pairs, 0); 209 krooted_tvs_push(K, tab); 210 for (i = 0; i < pairs; i += 2, rest = kcddr(rest)) 211 *klispH_set(K, tv2table(tab), kcar(rest)) = kcadr(rest); 212 krooted_tvs_pop(K); 213 kapply_cc(K, tab); 214 } 215 216 static void alist_to_hash_table(klisp_State *K) 217 { 218 int32_t pairs, i; 219 bind_1p(K, K->next_value, rest); 220 check_typed_list(K, kpairp, true, rest, &pairs, NULL); 221 222 TValue tab = klispH_new(K, 0, 32 + 2 * pairs, 0); 223 krooted_tvs_push(K, tab); 224 for (i = 0; i < pairs; i++, rest = kcdr(rest)) 225 *klispH_set(K, tv2table(tab), kcaar(rest)) = kcdar(rest); 226 krooted_tvs_pop(K); 227 kapply_cc(K, tab); 228 } 229 230 static void hash_table_merge(klisp_State *K) 231 { 232 int32_t pairs; 233 bool destructive = bvalue(K->next_xparams[0]); 234 bool only_one_arg = ivalue(K->next_xparams[1]); 235 TValue dest, rest = K->next_value; 236 237 check_typed_list(K, ktablep, true, rest, &pairs, NULL); 238 if (only_one_arg && pairs != 1) { 239 klispE_throw_simple(K, "expected one argument"); 240 } 241 if (destructive) { 242 if (pairs == 0) 243 klispE_throw_simple(K, "expected at least one argument"); 244 dest = kcar(rest); 245 rest = kcdr(rest); 246 pairs--; 247 } else { 248 dest = klispH_new(K, 0, 32 + 2 * pairs, 0); 249 } 250 251 krooted_tvs_push(K, dest); 252 while (pairs--) { 253 TValue key = KFREE, data; 254 Table *t = tv2table(kcar(rest)); 255 while (klispH_next(K, t, &key, &data)) 256 *klispH_set(K, tv2table(dest), key) = data; 257 rest = kcdr(rest); 258 } 259 krooted_tvs_pop(K); 260 261 kapply_cc(K, (destructive ? KINERT : dest)); 262 } 263 264 /* table_elements(K, TAB, MKELT) calls MKELT(key, value) 265 * on each key=>value binding in TAB and returns a list 266 * of objects returned by MKELT. TAB must be rooted. 267 */ 268 static TValue table_elements 269 (klisp_State *K, Table *t, 270 TValue (*mkelt)(klisp_State *K, TValue k, TValue v)) 271 { 272 TValue key = KFREE, data, res = KNIL, elt = KINERT; 273 274 krooted_vars_push(K, &res); 275 krooted_vars_push(K, &elt); 276 while (klispH_next(K, t, &key, &data)) { 277 elt = mkelt(K, key, data); 278 res = kcons(K, elt, res); 279 } 280 krooted_vars_pop(K); 281 krooted_vars_pop(K); 282 return res; 283 } 284 285 static TValue mkelt_proj1(klisp_State *K, TValue k, TValue v) 286 { 287 UNUSED(K); 288 UNUSED(v); 289 return k; 290 } 291 292 static TValue mkelt_proj2(klisp_State *K, TValue k, TValue v) 293 { 294 UNUSED(K); 295 UNUSED(k); 296 return v; 297 } 298 299 static TValue mkelt_cons(klisp_State *K, TValue k, TValue v) 300 { 301 return kcons(K, k, v); 302 } 303 304 static void hash_table_to_list(klisp_State *K) 305 { 306 bind_1tp(K, K->next_value, "hash table", ttistable, tab); 307 TValue res = table_elements(K, tv2table(tab), pvalue(K->next_xparams[0])); 308 kapply_cc(K, res); 309 } 310 311 /* init ground */ 312 void kinit_tables_ground_env(klisp_State *K) 313 { 314 TValue ground_env = G(K)->ground_env; 315 TValue symbol, value; 316 317 add_applicative(K, ground_env, "hash-table?", typep, 2, symbol, 318 i2tv(K_TTABLE)); 319 add_applicative(K, ground_env, "make-hash-table", make_hash_table, 0); 320 321 add_applicative(K, ground_env, "hash-table-set!", hash_table_setB, 0); 322 add_applicative(K, ground_env, "hash-table-ref", hash_table_ref, 0); 323 add_applicative(K, ground_env, "hash-table-exists?", hash_table_existsP, 0); 324 add_applicative(K, ground_env, "hash-table-delete!", hash_table_deleteB, 0); 325 add_applicative(K, ground_env, "hash-table-length", hash_table_length, 0); 326 327 add_applicative(K, ground_env, "hash-table", hash_table_constructor, 0); 328 add_applicative(K, ground_env, "alist->hash-table", alist_to_hash_table, 0); 329 330 add_applicative(K, ground_env, "hash-table-merge", hash_table_merge, 2, KFALSE, KFALSE); 331 add_applicative(K, ground_env, "hash-table-copy", hash_table_merge, 2, KFALSE, KTRUE); 332 add_applicative(K, ground_env, "hash-table-merge!", hash_table_merge, 2, KTRUE, KFALSE); 333 334 add_applicative(K, ground_env, "hash-table-keys", hash_table_to_list, 1, p2tv(mkelt_proj1)); 335 add_applicative(K, ground_env, "hash-table-values", hash_table_to_list, 1, p2tv(mkelt_proj2)); 336 add_applicative(K, ground_env, "hash-table->alist", hash_table_to_list, 1, p2tv(mkelt_cons)); 337 }