kghelpers.h (24517B)
1 /* 2 ** kghelpers.h 3 ** Helper macros and functions for the ground environment 4 ** See Copyright Notice in klisp.h 5 */ 6 7 #ifndef kghelpers_h 8 #define kghelpers_h 9 10 #include <assert.h> 11 #include <stdlib.h> 12 #include <stdio.h> 13 #include <stdbool.h> 14 #include <stdint.h> 15 16 #include "kstate.h" 17 #include "kobject.h" 18 #include "klisp.h" 19 #include "kerror.h" 20 #include "kpair.h" 21 #include "kvector.h" 22 #include "kapplicative.h" 23 #include "koperative.h" 24 #include "kcontinuation.h" 25 #include "kenvironment.h" 26 #include "ksymbol.h" 27 #include "kstring.h" 28 #include "ktable.h" 29 30 /* 31 ** REFACTOR split this file into several. 32 ** Some should have their own files (like knumber, kbool, etc) 33 ** Others are simply helpers that should be split into modules 34 ** (like continuation helpers, list helpers, environment helpers) 35 */ 36 37 /* Initialization of continuation names */ 38 void kinit_kghelpers_cont_names(klisp_State *K); 39 40 /* to use in type checking binds when no check is needed */ 41 #define anytype(obj_) (true) 42 43 /* Type predicates */ 44 /* TODO these should be moved to either kobject.h or the corresponding 45 files (e.g. kbooleanp to kboolean.h */ 46 bool kbooleanp(TValue obj); 47 bool kcombinerp(TValue obj); 48 bool knumberp(TValue obj); 49 bool knumber_wpvp(TValue obj); 50 bool kfinitep(TValue obj); 51 bool kintegerp(TValue obj); 52 bool keintegerp(TValue obj); 53 bool krationalp(TValue obj); 54 bool krealp(TValue obj); 55 bool kreal_wpvp(TValue obj); 56 bool kexactp(TValue obj); 57 bool kinexactp(TValue obj); 58 bool kundefinedp(TValue obj); 59 bool krobustp(TValue obj); 60 bool ku8p(TValue obj); 61 /* This is used in gcd & lcm */ 62 bool kimp_intp(TValue obj); 63 64 /* needed by kgffi.c and encapsulations */ 65 void enc_typep(klisp_State *K); 66 67 /* /Type predicates */ 68 69 /* some number predicates */ 70 /* REFACTOR: These should be in a knumber.h header */ 71 72 /* Misc Helpers */ 73 /* TEMP: only reals (no complex numbers) */ 74 bool kpositivep(TValue n); 75 bool knegativep(TValue n); 76 77 static inline bool kfast_zerop(TValue n) 78 { 79 return (ttisfixint(n) && ivalue(n) == 0) || 80 (ttisdouble(n) && dvalue(n) == 0.0); 81 } 82 83 static inline bool kfast_onep(TValue n) 84 { 85 return (ttisfixint(n) && ivalue(n) == 1) || 86 (ttisdouble(n) && dvalue(n) == 1.0); 87 } 88 89 static inline TValue kneg_inf(TValue i) 90 { 91 if (ttiseinf(i)) 92 return tv_equal(i, KEPINF)? KEMINF : KEPINF; 93 else /* ttisiinf(i) */ 94 return tv_equal(i, KIPINF)? KIMINF : KIPINF; 95 } 96 97 static inline bool knum_same_signp(klisp_State *K, TValue n1, TValue n2) 98 { 99 return kpositivep(n1) == kpositivep(n2); 100 } 101 102 /* /some number predicates */ 103 104 /* 105 ** NOTE: these are intended to be used at the beginning of a function 106 ** they expand to more than one statement and may evaluate some of 107 ** their arguments more than once 108 */ 109 110 /* XXX: add parens around macro vars!! */ 111 /* TODO try to rewrite all of these with just check_0p and check_al1p, 112 (the same with check_0tp and check_al1tp) 113 add a number param and use an array of strings for msgs */ 114 115 #define check_0p(K_, ptree_) \ 116 if (!ttisnil(ptree_)) { \ 117 klispE_throw_simple((K_), \ 118 "Bad ptree (expected no arguments)"); \ 119 return; \ 120 } 121 122 #define bind_1p(K_, ptree_, v_) \ 123 bind_1tp((K_), (ptree_), "any", anytype, (v_)) 124 125 #define bind_1tp(K_, ptree_, tstr_, t_, v_) \ 126 TValue v_; \ 127 if (!ttispair(ptree_) || !ttisnil(kcdr(ptree_))) { \ 128 klispE_throw_simple((K_), \ 129 "Bad ptree (expected one argument)"); \ 130 return; \ 131 } \ 132 v_ = kcar(ptree_); \ 133 if (!t_(v_)) { \ 134 klispE_throw_simple(K_, "Bad type on first argument " \ 135 "(expected " tstr_ ")"); \ 136 return; \ 137 } 138 139 140 #define bind_2p(K_, ptree_, v1_, v2_) \ 141 bind_2tp((K_), (ptree_), "any", anytype, (v1_), \ 142 "any", anytype, (v2_)) 143 144 #define bind_2tp(K_, ptree_, tstr1_, t1_, v1_, \ 145 tstr2_, t2_, v2_) \ 146 TValue v1_, v2_; \ 147 if (!ttispair(ptree_) || !ttispair(kcdr(ptree_)) || \ 148 !ttisnil(kcddr(ptree_))) { \ 149 klispE_throw_simple(K_, "Bad ptree (expected two arguments)"); \ 150 return; \ 151 } \ 152 v1_ = kcar(ptree_); \ 153 v2_ = kcadr(ptree_); \ 154 if (!t1_(v1_)) { \ 155 klispE_throw_simple(K_, "Bad type on first argument (expected " \ 156 tstr1_ ")"); \ 157 return; \ 158 } else if (!t2_(v2_)) { \ 159 klispE_throw_simple(K_, "Bad type on second argument (expected " \ 160 tstr2_ ")"); \ 161 return; \ 162 } 163 164 #define bind_3p(K_, ptree_, v1_, v2_, v3_) \ 165 bind_3tp(K_, ptree_, "any", anytype, v1_, \ 166 "any", anytype, v2_, "any", anytype, v3_) 167 168 #define bind_3tp(K_, ptree_, tstr1_, t1_, v1_, \ 169 tstr2_, t2_, v2_, tstr3_, t3_, v3_) \ 170 TValue v1_, v2_, v3_; \ 171 if (!ttispair(ptree_) || !ttispair(kcdr(ptree_)) || \ 172 !ttispair(kcddr (ptree_)) || !ttisnil(kcdddr(ptree_))) { \ 173 klispE_throw_simple(K_, "Bad ptree (expected three arguments)"); \ 174 return; \ 175 } \ 176 v1_ = kcar(ptree_); \ 177 v2_ = kcadr(ptree_); \ 178 v3_ = kcaddr(ptree_); \ 179 if (!t1_(v1_)) { \ 180 klispE_throw_simple(K_, "Bad type on first argument (expected " \ 181 tstr1_ ")"); \ 182 return; \ 183 } else if (!t2_(v2_)) { \ 184 klispE_throw_simple(K_, "Bad type on second argument (expected " \ 185 tstr2_ ")"); \ 186 return; \ 187 } else if (!t3_(v3_)) { \ 188 klispE_throw_simple(K_, "Bad type on third argument (expected " \ 189 tstr3_ ")"); \ 190 return; \ 191 } 192 193 /* bind at least 1 parameter, like (v1_ . v2_) */ 194 #define bind_al1p(K_, ptree_, v1_, v2_) \ 195 bind_al1tp((K_), (ptree_), "any", anytype, (v1_), (v2_)) 196 197 /* bind at least 1 parameters (with type), like (v1_ . v2_) */ 198 #define bind_al1tp(K_, ptree_, tstr1_, t1_, v1_, v2_) \ 199 TValue v1_, v2_; \ 200 if (!ttispair(ptree_)) { \ 201 klispE_throw_simple(K_, "Bad ptree (expected at least " \ 202 "one argument)"); \ 203 return; \ 204 } \ 205 v1_ = kcar(ptree_); \ 206 v2_ = kcdr(ptree_); \ 207 if (!t1_(v1_)) { \ 208 klispE_throw_simple(K_, "Bad type on first argument (expected " \ 209 tstr1_ ")"); \ 210 return; \ 211 } 212 213 /* bind at least 2 parameters, like (v1_ v2_ . v3_) */ 214 #define bind_al2p(K_, ptree_, v1_, v2_, v3_) \ 215 bind_al2tp((K_), (ptree_), "any", anytype, (v1_), \ 216 "any", anytype, (v2_), (v3_)) 217 218 /* bind at least 2 parameters (with type), like (v1_ v2_ . v3_) */ 219 #define bind_al2tp(K_, ptree_, tstr1_, t1_, v1_, \ 220 tstr2_, t2_, v2_, v3_) \ 221 TValue v1_, v2_, v3_; \ 222 if (!ttispair(ptree_) || !ttispair(kcdr(ptree_))) { \ 223 klispE_throw_simple(K_, "Bad ptree (expected at least " \ 224 "two arguments)"); \ 225 return; \ 226 } \ 227 v1_ = kcar(ptree_); \ 228 v2_ = kcadr(ptree_); \ 229 v3_ = kcddr(ptree_); \ 230 if (!t1_(v1_)) { \ 231 klispE_throw_simple(K_, "Bad type on first argument (expected " \ 232 tstr1_ ")"); \ 233 return; \ 234 } else if (!t2_(v2_)) { \ 235 klispE_throw_simple(K_, "Bad type on second argument (expected " \ 236 tstr2_ ")"); \ 237 return; \ 238 } 239 240 /* bind at least 3 parameters, like (v1_ v2_ v3_ . v4_) */ 241 #define bind_al3p(K_, ptree_, v1_, v2_, v3_, v4_) \ 242 bind_al3tp((K_), (ptree_), "any", anytype, (v1_), \ 243 "any", anytype, (v2_), "any", anytype, (v3_), (v4_)) \ 244 245 /* bind at least 3 parameters (with type), like (v1_ v2_ v3_ . v4_) */ 246 #define bind_al3tp(K_, ptree_, tstr1_, t1_, v1_, \ 247 tstr2_, t2_, v2_, tstr3_, t3_, v3_, v4_) \ 248 TValue v1_, v2_, v3_, v4_; \ 249 if (!ttispair(ptree_) || !ttispair(kcdr(ptree_)) || \ 250 !ttispair(kcddr(ptree_))) { \ 251 klispE_throw_simple(K_, "Bad ptree (expected at least " \ 252 "three arguments)"); \ 253 return; \ 254 } \ 255 v1_ = kcar(ptree_); \ 256 v2_ = kcadr(ptree_); \ 257 v3_ = kcaddr(ptree_); \ 258 v4_ = kcdddr(ptree_); \ 259 if (!t1_(v1_)) { \ 260 klispE_throw_simple(K_, "Bad type on first argument (expected " \ 261 tstr1_ ")"); \ 262 return; \ 263 } else if (!t2_(v2_)) { \ 264 klispE_throw_simple(K_, "Bad type on second argument (expected " \ 265 tstr2_ ")"); \ 266 return; \ 267 } else if (!t3_(v3_)) { \ 268 klispE_throw_simple(K_, "Bad type on third argument (expected " \ 269 tstr3_ ")"); \ 270 return; \ 271 } 272 273 274 /* returns true if the obj pointed by par is a list of one element of 275 type type, and puts that element in par 276 returns false if par is nil 277 In any other case it throws an error */ 278 #define get_opt_tpar(K_, par_, tstr_, t_) ({ \ 279 bool res_; \ 280 if (ttisnil(par_)) { \ 281 res_ = false; \ 282 } else if (!ttispair(par_) || !ttisnil(kcdr(par_))) { \ 283 klispE_throw_simple((K_), \ 284 "Bad ptree structure " \ 285 "(in optional argument)"); \ 286 return; \ 287 } else if (!t_(kcar(par_))) { \ 288 klispE_throw_simple(K_, "Bad type on optional argument " \ 289 "(expected " tstr_ ")"); \ 290 return; \ 291 } else { \ 292 par_ = kcar(par_); \ 293 res_ = true; \ 294 } \ 295 res_; }) 296 297 /* 298 ** This states are useful for traversing trees, saving the state in the 299 ** token char buffer 300 */ 301 #define ST_PUSH ((char) 0) 302 #define ST_CAR ((char) 1) 303 #define ST_CDR ((char) 2) 304 305 /* 306 ** Unmarking structures. 307 ** MAYBE: These shouldn't be inline really. 308 ** These two stop at the first object that is not a marked pair 309 */ 310 static inline void unmark_list(klisp_State *K, TValue obj) 311 { 312 UNUSED(K); /* not needed, it's here for consistency */ 313 while(ttispair(obj) && kis_marked(obj)) { 314 kunmark(obj); 315 obj = kcdr(obj); 316 } 317 } 318 319 static inline void unmark_tree(klisp_State *K, TValue obj) 320 { 321 assert(ks_sisempty(K)); 322 323 ks_spush(K, obj); 324 325 while(!ks_sisempty(K)) { 326 obj = ks_spop(K); 327 328 if (ttispair(obj) && kis_marked(obj)) { 329 kunmark(obj); 330 ks_spush(K, kcdr(obj)); 331 ks_spush(K, kcar(obj)); 332 } else if (ttisvector(obj) && kis_marked(obj)) { 333 kunmark(obj); 334 uint32_t i = kvector_size(obj); 335 const TValue *array = kvector_buf(obj); 336 while(i-- > 0) 337 ks_spush(K, array[i]); 338 } 339 } 340 } 341 342 /* 343 ** Structure checking and copying 344 */ 345 346 /* TODO: move all bools to a flag parameter (with constants like 347 KCHK_LS_FORCE_COPY, KCHK_ALLOW_CYCLE, KCHK_AVOID_ENCYCLE, etc) */ 348 /* typed finite list. Structure error are thrown before type errors */ 349 void check_typed_list(klisp_State *K, bool (*typep)(TValue), bool allow_infp, 350 TValue obj, int32_t *pairs, int32_t *cpairs); 351 352 /* check that obj is a list, returns the number of pairs */ 353 void check_list(klisp_State *K, bool allow_infp, TValue obj, 354 int32_t *pairs, int32_t *cpairs); 355 356 /* TODO: add unchecked_copy_list */ 357 /* TODO: add check_copy_typed_list */ 358 /* check that obj is a list and make a copy if it is not immutable or 359 force_copy is true */ 360 /* GC: assumes obj is rooted */ 361 TValue check_copy_list(klisp_State *K, TValue obj, bool force_copy, 362 int32_t *pairs, int32_t *cpairs); 363 364 /* Reverse the ls list and encycle the result if needed */ 365 /* GC: assumes ls is rooted */ 366 TValue reverse_copy_and_encycle(klisp_State *K, TValue ls, int32_t pairs, 367 int32_t cpairs); 368 369 /* check that obj is a list of environments and make a copy but don't keep 370 the cycles */ 371 /* GC: assume obj is rooted */ 372 TValue check_copy_env_list(klisp_State *K, TValue obj); 373 374 /* The assimetry in error checking in the following functions 375 is a product of the contexts in which they are used, see the 376 .c for an enumeration of such contexts */ 377 /* list->? conversion functions, only type errors of elems checked */ 378 TValue list_to_string_h(klisp_State *K, TValue ls, int32_t length); 379 TValue list_to_vector_h(klisp_State *K, TValue ls, int32_t length); 380 TValue list_to_bytevector_h(klisp_State *K, TValue ls, int32_t length); 381 382 /* ?->list conversion functions, type checked */ 383 TValue string_to_list_h(klisp_State *K, TValue obj, int32_t *length); 384 TValue vector_to_list_h(klisp_State *K, TValue obj, int32_t *length); 385 TValue bytevector_to_list_h(klisp_State *K, TValue obj, int32_t *length); 386 387 /* 388 ** Generic function for type predicates 389 ** It can only be used by types that have a unique tag 390 */ 391 void typep(klisp_State *K); 392 393 /* 394 ** Generic function for type predicates 395 ** It takes an arbitrary function pointer of type bool (*fn)(TValue o) 396 */ 397 void ftypep(klisp_State *K); 398 399 /* 400 ** Generic function for typed predicates (like char-alphabetic? or finite?) 401 ** A typed predicate is a predicate that requires its arguments to be a certain 402 ** type. This takes a function pointer for the type & one for the predicate, 403 ** both of the same type: bool (*fn)(TValue o). 404 ** On zero operands this return true 405 */ 406 void ftyped_predp(klisp_State *K); 407 408 /* 409 ** Generic function for typed binary predicates (like =? & char<?) 410 ** A typed predicate is a predicate that requires its arguments to be a certain 411 ** type. This takes a function pointer for the type bool (*typep)(TValue o) 412 ** & one for the predicate: bool (*fn)(TValue o1, TValue o2). 413 ** This assumes the predicate is transitive and works even in cyclic lists 414 ** On zero and one operand this return true 415 */ 416 void ftyped_bpredp(klisp_State *K); 417 418 /* This is the same, but the comparison predicate takes a klisp_State */ 419 /* TODO unify them */ 420 void ftyped_kbpredp(klisp_State *K); 421 422 /* Continuations that are used in more than one file */ 423 void do_seq(klisp_State *K); 424 void do_pass_value(klisp_State *K); 425 void do_return_value(klisp_State *K); 426 void do_bind(klisp_State *K); 427 void do_access(klisp_State *K); 428 void do_unbind(klisp_State *K); 429 void do_set_pass(klisp_State *K); 430 /* /Continuations that are used in more than one file */ 431 432 /* dynamic var */ 433 TValue make_bind_continuation(klisp_State *K, TValue key, 434 TValue old_flag, TValue old_value, 435 TValue new_flag, TValue new_value); 436 437 TValue check_copy_guards(klisp_State *K, char *name, TValue obj); 438 void guard_dynamic_extent(klisp_State *K); 439 440 /* Some helpers for working with fixints (signed 32 bits) */ 441 static inline int32_t kabs32(int32_t a) { return a < 0? -a : a; } 442 static inline int64_t kabs64(int64_t a) { return a < 0? -a : a; } 443 static inline int32_t kmin32(int32_t a, int32_t b) { return a < b? a : b; } 444 static inline int32_t kmax32(int32_t a, int32_t b) { return a > b? a : b; } 445 446 static inline int32_t kcheck32(klisp_State *K, char *msg, int64_t i) 447 { 448 if (i > (int64_t) INT32_MAX || i < (int64_t) INT32_MIN) { 449 klispE_throw_simple(K, msg); 450 return 0; 451 } else { 452 return (int32_t) i; 453 } 454 } 455 456 /* gcd for two numbers, used for gcd, lcm & map */ 457 int64_t kgcd32_64(int32_t a, int32_t b); 458 int64_t klcm32_64(int32_t a, int32_t b); 459 460 /* 461 ** Other 462 */ 463 464 /* memoize applicative (used in kstate & promises) */ 465 void memoize(klisp_State *K); 466 /* list applicative (used in kstate and kgpairs_lists) */ 467 void list(klisp_State *K); 468 469 /* Helper for list-tail, list-ref and list-set! */ 470 int32_t ksmallest_index(klisp_State *K, TValue obj, TValue tk); 471 472 /* Helper for get-list-metrics, and list-tail, list-ref and list-set! 473 when receiving bigint indexes */ 474 void get_list_metrics_aux(klisp_State *K, TValue obj, int32_t *p, int32_t *n, 475 int32_t *a, int32_t *c); 476 477 /* Helper for eq? and equal? */ 478 bool eq2p(klisp_State *K, TValue obj1, TValue obj2); 479 480 /* Helper for equal?, assoc and member */ 481 /* compare two objects and check to see if they are "equal?". */ 482 bool equal2p(klisp_State *K, TValue obj1, TValue obj2); 483 484 /* Helper (also used by $vau, $lambda, etc) */ 485 TValue copy_es_immutable_h(klisp_State *K, TValue ptree, bool mut_flag); 486 487 /* ptree handling */ 488 void match(klisp_State *K, TValue env, TValue ptree, TValue obj); 489 TValue check_copy_ptree(klisp_State *K, TValue ptree, TValue penv); 490 491 /* map/$for-each */ 492 /* Helpers for map (also used by for-each) */ 493 494 /* Calculate the metrics for both the result list and the ptree 495 passed to the applicative */ 496 void map_for_each_get_metrics( 497 klisp_State *K, TValue lss, int32_t *app_apairs_out, 498 int32_t *app_cpairs_out, int32_t *res_apairs_out, int32_t *res_cpairs_out); 499 500 /* Return two lists, isomorphic to lss: one list of cars and one list 501 of cdrs (replacing the value of lss) */ 502 /* GC: Assumes lss is rooted */ 503 TValue map_for_each_get_cars_cdrs(klisp_State *K, TValue *lss, 504 int32_t apairs, int32_t cpairs); 505 506 /* Transpose lss so that the result is a list of lists, each one having 507 metrics (app_apairs, app_cpairs). The metrics of the returned list 508 should be (res_apairs, res_cpairs) */ 509 510 /* GC: Assumes lss is rooted */ 511 TValue map_for_each_transpose(klisp_State *K, TValue lss, 512 int32_t app_apairs, int32_t app_cpairs, 513 int32_t res_apairs, int32_t res_cpairs); 514 515 516 /* for thread continuation guarding */ 517 void do_int_mark_root(klisp_State *K); 518 void do_int_mark_error(klisp_State *K); 519 520 /* TODO add handler for entry guards to avoid 521 continuations to cross threads */ 522 523 /* 524 ** Macros for ground environment initialization 525 */ 526 527 /* 528 ** BEWARE: this is highly unhygienic, it assumes variables "symbol" and 529 ** "value", both of type TValue. symbol will be bound to a symbol named by 530 ** "n_" and can be referrenced in the var_args 531 ** GC: All of these should be called when GC is deactivated 532 */ 533 534 /* TODO add si to the symbols */ 535 #if KTRACK_SI 536 #define add_operative(K_, env_, n_, fn_, ...) \ 537 { symbol = ksymbol_new_b(K_, n_, KNIL); \ 538 value = kmake_operative(K_, fn_, __VA_ARGS__); \ 539 TValue str = kstring_new_b_imm(K_, __FILE__); \ 540 TValue si = kcons(K, str, kcons(K_, i2tv(__LINE__), \ 541 i2tv(0))); \ 542 kset_source_info(K_, value, si); \ 543 kadd_binding(K_, env_, symbol, value); } 544 545 #define add_applicative(K_, env_, n_, fn_, ...) \ 546 { symbol = ksymbol_new_b(K_, n_, KNIL); \ 547 value = kmake_applicative(K_, fn_, __VA_ARGS__); \ 548 TValue str = kstring_new_b_imm(K_, __FILE__); \ 549 TValue si = kcons(K, str, kcons(K_, i2tv(__LINE__), \ 550 i2tv(0))); \ 551 kset_source_info(K_, kunwrap(value), si); \ 552 kset_source_info(K_, value, si); \ 553 kadd_binding(K_, env_, symbol, value); } 554 #else /* KTRACK_SI */ 555 #define add_operative(K_, env_, n_, fn_, ...) \ 556 { symbol = ksymbol_new_b(K_, n_, KNIL); \ 557 value = kmake_operative(K_, fn_, __VA_ARGS__); \ 558 kadd_binding(K_, env_, symbol, value); } 559 560 #define add_applicative(K_, env_, n_, fn_, ...) \ 561 { symbol = ksymbol_new_b(K_, n_, KNIL); \ 562 value = kmake_applicative(K_, fn_, __VA_ARGS__); \ 563 kadd_binding(K_, env_, symbol, value); } 564 #endif /* KTRACK_SI */ 565 566 #define add_value(K_, env_, n_, v_) \ 567 { value = v_; \ 568 symbol = ksymbol_new_b(K_, n_, KNIL); \ 569 kadd_binding(K_, env_, symbol, v_); } 570 571 #endif 572 573 /* for initiliazing continuation names */ 574 #define add_cont_name(K_, t_, c_, n_) \ 575 { TValue str = kstring_new_b_imm(K_, n_); \ 576 TValue *node = klispH_set(K_, t_, p2tv(c_)); \ 577 *node = str; \ 578 } 579