kgvectors.c (14388B)
1 /* 2 ** kgvectors.c 3 ** Vector (heterogenous array) features 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 "kvector.h" 21 #include "kpair.h" 22 #include "kbytevector.h" 23 24 #include "kghelpers.h" 25 #include "kgvectors.h" 26 27 /* (R7RS 3rd draft 6.3.6) vector? */ 28 /* uses typep */ 29 30 /* ?.?.? immutable-vector?, mutable-vector? */ 31 /* use ftypep */ 32 33 /* (R7RS 3rd draft 6.3.6) make-vector */ 34 void make_vector(klisp_State *K) 35 { 36 klisp_assert(ttisenvironment(K->next_env)); 37 TValue ptree = K->next_value; 38 39 bind_al1tp(K, ptree, "exact integer", keintegerp, tv_s, fill); 40 if (!get_opt_tpar(K, fill, "any", anytype)) 41 fill = KINERT; 42 43 if (knegativep(tv_s)) { 44 klispE_throw_simple(K, "negative vector length"); 45 return; 46 } else if (!ttisfixint(tv_s)) { 47 klispE_throw_simple(K, "vector length is too big"); 48 return; 49 } 50 TValue new_vector = (ivalue(tv_s) == 0)? 51 G(K)->empty_vector 52 : kvector_new_sf(K, ivalue(tv_s), fill); 53 kapply_cc(K, new_vector); 54 } 55 56 /* (R7RS 3rd draft 6.3.6) vector-length */ 57 void vector_length(klisp_State *K) 58 { 59 klisp_assert(ttisenvironment(K->next_env)); 60 TValue ptree = K->next_value; 61 62 bind_1tp(K, ptree, "vector", ttisvector, vector); 63 64 TValue res = i2tv(kvector_size(vector)); 65 kapply_cc(K, res); 66 } 67 68 /* (R7RS 3rd draft 6.3.6) vector-ref */ 69 void vector_ref(klisp_State *K) 70 { 71 klisp_assert(ttisenvironment(K->next_env)); 72 73 TValue ptree = K->next_value; 74 bind_2tp(K, ptree, "vector", ttisvector, vector, 75 "exact integer", keintegerp, tv_i); 76 77 if (!ttisfixint(tv_i)) { 78 klispE_throw_simple_with_irritants(K, "vector index out of bounds", 79 1, tv_i); 80 return; 81 } 82 int32_t i = ivalue(tv_i); 83 if (i < 0 || i >= kvector_size(vector)) { 84 klispE_throw_simple_with_irritants(K, "vector index out of bounds", 85 1, tv_i); 86 return; 87 } 88 kapply_cc(K, kvector_buf(vector)[i]); 89 } 90 91 /* (R7RS 3rd draft 6.3.6) vector-set! */ 92 void vector_setB(klisp_State *K) 93 { 94 klisp_assert(ttisenvironment(K->next_env)); 95 96 TValue ptree = K->next_value; 97 bind_3tp(K, ptree, "vector", ttisvector, vector, 98 "exact integer", keintegerp, tv_i, "any", anytype, tv_new_value); 99 100 if (!ttisfixint(tv_i)) { 101 klispE_throw_simple_with_irritants(K, "vector index out of bounds", 102 1, tv_i); 103 return; 104 } 105 106 int32_t i = ivalue(tv_i); 107 if (i < 0 || i >= kvector_size(vector)) { 108 klispE_throw_simple_with_irritants(K, "vector index out of bounds", 109 1, tv_i); 110 return; 111 } else if (kvector_immutablep(vector)) { 112 klispE_throw_simple(K, "immutable vector"); 113 return; 114 } 115 116 kvector_buf(vector)[i] = tv_new_value; 117 kapply_cc(K, KINERT); 118 } 119 120 /* (R7RS 3rd draft 6.3.6) vector-copy */ 121 /* TEMP: at least for now this always returns mutable vectors */ 122 void vector_copy(klisp_State *K) 123 { 124 klisp_assert(ttisenvironment(K->next_env)); 125 TValue ptree = K->next_value; 126 127 bind_1tp(K, ptree, "vector", ttisvector, v); 128 129 TValue new_vector = kvector_emptyp(v)? 130 v 131 : kvector_new_bs_g(K, true, kvector_buf(v), kvector_size(v)); 132 kapply_cc(K, new_vector); 133 } 134 135 /* (R7RS 3rd draft 6.3.6) vector */ 136 void vector(klisp_State *K) 137 { 138 klisp_assert(ttisenvironment(K->next_env)); 139 140 TValue ptree = K->next_value; 141 /* don't allow cycles */ 142 int32_t pairs; 143 check_list(K, false, ptree, &pairs, NULL); 144 TValue res = list_to_vector_h(K, ptree, pairs); 145 kapply_cc(K, res); 146 } 147 148 /* (R7RS 3rd draft 6.3.6) list->vector */ 149 void list_to_vector(klisp_State *K) 150 { 151 klisp_assert(ttisenvironment(K->next_env)); 152 153 TValue ptree = K->next_value; 154 bind_1p(K, ptree, ls); 155 /* don't allow cycles */ 156 int32_t pairs; 157 check_list(K, false, ls, &pairs, NULL); 158 TValue res = list_to_vector_h(K, ls, pairs); 159 kapply_cc(K, res); 160 } 161 162 /* (R7RS 3rd draft 6.3.6) vector->list */ 163 void vector_to_list(klisp_State *K) 164 { 165 klisp_assert(ttisenvironment(K->next_env)); 166 167 TValue ptree = K->next_value; 168 bind_1tp(K, ptree, "vector", ttisvector, v); 169 170 TValue res = vector_to_list_h(K, v, NULL); 171 kapply_cc(K, res); 172 } 173 174 /* 13.? bytevector->vector, vector->bytevector */ 175 void bytevector_to_vector(klisp_State *K) 176 { 177 TValue *xparams = K->next_xparams; 178 TValue ptree = K->next_value; 179 TValue denv = K->next_env; 180 klisp_assert(ttisenvironment(K->next_env)); 181 UNUSED(xparams); 182 UNUSED(denv); 183 184 bind_1tp(K, ptree, "bytevector", ttisbytevector, str); 185 TValue res; 186 187 if (kbytevector_emptyp(str)) { 188 res = G(K)->empty_vector; 189 } else { 190 uint32_t size = kbytevector_size(str); 191 192 /* MAYBE add vector constructor without fill */ 193 /* no need to root this */ 194 res = kvector_new_sf(K, size, KINERT); 195 uint8_t *src = kbytevector_buf(str); 196 TValue *dst = kvector_buf(res); 197 while(size--) { 198 uint8_t u8 = *src++; /* not needed but just in case */ 199 *dst++ = i2tv(u8); 200 } 201 } 202 kapply_cc(K, res); 203 } 204 205 /* TEMP Only ASCII for now */ 206 void vector_to_bytevector(klisp_State *K) 207 { 208 TValue *xparams = K->next_xparams; 209 TValue ptree = K->next_value; 210 TValue denv = K->next_env; 211 klisp_assert(ttisenvironment(K->next_env)); 212 UNUSED(xparams); 213 UNUSED(denv); 214 215 bind_1tp(K, ptree, "vector", ttisvector, vec); 216 TValue res; 217 218 if (kvector_emptyp(vec)) { 219 res = G(K)->empty_bytevector; 220 } else { 221 uint32_t size = kvector_size(vec); 222 223 res = kbytevector_new_s(K, size); /* no need to root this */ 224 TValue *src = kvector_buf(vec); 225 uint8_t *dst = kbytevector_buf(res); 226 while(size--) { 227 TValue tv = *src++; 228 if (!ttisu8(tv)) { 229 klispE_throw_simple_with_irritants(K, "Non u8 object found", 230 1, tv); 231 return; 232 } 233 *dst++ = (uint8_t) ivalue(tv); 234 } 235 } 236 kapply_cc(K, res); 237 } 238 239 /* 13.2.9? vector-copy! */ 240 void vector_copyB(klisp_State *K) 241 { 242 TValue *xparams = K->next_xparams; 243 TValue ptree = K->next_value; 244 TValue denv = K->next_env; 245 klisp_assert(ttisenvironment(K->next_env)); 246 UNUSED(xparams); 247 UNUSED(denv); 248 bind_2tp(K, ptree, "vector", ttisvector, vector1, 249 "vector", ttisvector, vector2); 250 251 if (kvector_immutablep(vector2)) { 252 klispE_throw_simple(K, "immutable destination vector"); 253 return; 254 } else if (kvector_size(vector1) > kvector_size(vector2)) { 255 klispE_throw_simple(K, "destination vector is too small"); 256 return; 257 } 258 259 if (!tv_equal(vector1, vector2) && 260 !tv_equal(vector1, G(K)->empty_vector)) { 261 memcpy(kvector_buf(vector2), 262 kvector_buf(vector1), 263 kvector_size(vector1) * sizeof(TValue)); 264 } 265 kapply_cc(K, KINERT); 266 } 267 268 /* ?.? vector-copy-partial */ 269 /* TEMP: at least for now this always returns mutable vectors */ 270 void vector_copy_partial(klisp_State *K) 271 { 272 TValue *xparams = K->next_xparams; 273 TValue ptree = K->next_value; 274 TValue denv = K->next_env; 275 klisp_assert(ttisenvironment(K->next_env)); 276 UNUSED(xparams); 277 UNUSED(denv); 278 bind_3tp(K, ptree, "vector", ttisvector, vector, 279 "exact integer", keintegerp, tv_start, 280 "exact integer", keintegerp, tv_end); 281 282 if (!ttisfixint(tv_start) || ivalue(tv_start) < 0 || 283 ivalue(tv_start) > kvector_size(vector)) { 284 /* TODO show index */ 285 klispE_throw_simple(K, "start index out of bounds"); 286 return; 287 } 288 289 int32_t start = ivalue(tv_start); 290 291 if (!ttisfixint(tv_end) || ivalue(tv_end) < 0 || 292 ivalue(tv_end) > kvector_size(vector)) { 293 klispE_throw_simple(K, "end index out of bounds"); 294 return; 295 } 296 297 int32_t end = ivalue(tv_end); 298 299 if (start > end) { 300 /* TODO show indexes */ 301 klispE_throw_simple(K, "end index is smaller than start index"); 302 return; 303 } 304 305 int32_t size = end - start; 306 TValue new_vector; 307 /* the if isn't strictly necessary but it's clearer this way */ 308 if (size == 0) { 309 new_vector = G(K)->empty_vector; 310 } else { 311 new_vector = kvector_new_bs_g(K, true, kvector_buf(vector) 312 + start, size); 313 } 314 kapply_cc(K, new_vector); 315 } 316 317 /* ?.? vector-copy-partial! */ 318 void vector_copy_partialB(klisp_State *K) 319 { 320 TValue *xparams = K->next_xparams; 321 TValue ptree = K->next_value; 322 TValue denv = K->next_env; 323 klisp_assert(ttisenvironment(K->next_env)); 324 UNUSED(xparams); 325 UNUSED(denv); 326 bind_al3tp(K, ptree, "vector", ttisvector, vector1, 327 "exact integer", keintegerp, tv_start, 328 "exact integer", keintegerp, tv_end, 329 rest); 330 331 /* XXX: this will send wrong error msgs (bad number of arg) */ 332 bind_2tp(K, rest, 333 "vector", ttisvector, vector2, 334 "exact integer", keintegerp, tv_start2); 335 336 if (!ttisfixint(tv_start) || ivalue(tv_start) < 0 || 337 ivalue(tv_start) > kvector_size(vector1)) { 338 /* TODO show index */ 339 klispE_throw_simple(K, "start index out of bounds"); 340 return; 341 } 342 343 int32_t start = ivalue(tv_start); 344 345 if (!ttisfixint(tv_end) || ivalue(tv_end) < 0 || 346 ivalue(tv_end) > kvector_size(vector1)) { 347 klispE_throw_simple(K, "end index out of bounds"); 348 return; 349 } 350 351 int32_t end = ivalue(tv_end); 352 353 if (start > end) { 354 /* TODO show indexes */ 355 klispE_throw_simple(K, "end index is smaller than start index"); 356 return; 357 } 358 359 int32_t size = end - start; 360 361 if (kvector_immutablep(vector2)) { 362 klispE_throw_simple(K, "immutable destination vector"); 363 return; 364 } 365 366 if (!ttisfixint(tv_start2) || ivalue(tv_start2) < 0 || 367 ivalue(tv_start2) > kvector_size(vector2)) { 368 klispE_throw_simple(K, "to index out of bounds"); 369 return; 370 } 371 372 int32_t start2 = ivalue(tv_start2); 373 int64_t end2 = (int64_t) start2 + size; 374 375 if ((end2 > INT32_MAX) || 376 (((int32_t) end2) > kvector_size(vector2))) { 377 klispE_throw_simple(K, "not enough space in destination"); 378 return; 379 } 380 381 if (size > 0) { 382 memcpy(kvector_buf(vector2) + start2, 383 kvector_buf(vector1) + start, 384 size * sizeof(TValue)); 385 } 386 kapply_cc(K, KINERT); 387 } 388 389 /* ?.? vector-fill! */ 390 void vector_fillB(klisp_State *K) 391 { 392 TValue *xparams = K->next_xparams; 393 TValue ptree = K->next_value; 394 TValue denv = K->next_env; 395 klisp_assert(ttisenvironment(K->next_env)); 396 UNUSED(xparams); 397 UNUSED(denv); 398 bind_2tp(K, ptree, "vector", ttisvector, vector, 399 "any", anytype, fill); 400 401 if (kvector_immutablep(vector)) { 402 klispE_throw_simple(K, "immutable vector"); 403 return; 404 } 405 406 uint32_t size = kvector_size(vector); 407 TValue *buf = kvector_buf(vector); 408 while(size-- > 0) { 409 *buf++ = fill; 410 } 411 kapply_cc(K, KINERT); 412 } 413 414 /* ??.?.? vector->immutable-vector */ 415 void vector_to_immutable_vector(klisp_State *K) 416 { 417 klisp_assert(ttisenvironment(K->next_env)); 418 419 TValue ptree = K->next_value; 420 bind_1tp(K, ptree, "vector", ttisvector, v); 421 422 TValue res = kvector_immutablep(v)? 423 v 424 : kvector_new_bs_g(K, false, kvector_buf(v), kvector_size(v)); 425 kapply_cc(K, res); 426 } 427 428 /* init ground */ 429 void kinit_vectors_ground_env(klisp_State *K) 430 { 431 TValue ground_env = G(K)->ground_env; 432 TValue symbol, value; 433 434 /* 435 ** This section is not in the report. The bindings here are 436 ** taken from the r7rs scheme draft and should not be considered standard. 437 ** They are provided in the meantime to allow programs to use vectors. 438 */ 439 440 /* (R7RS 3rd draft 6.3.6) vector? */ 441 add_applicative(K, ground_env, "vector?", typep, 2, symbol, 442 i2tv(K_TVECTOR)); 443 /* ??.? immutable-vector?, mutable-vector? */ 444 add_applicative(K, ground_env, "immutable-vector?", ftypep, 2, symbol, 445 p2tv(kimmutable_vectorp)); 446 add_applicative(K, ground_env, "mutable-vector?", ftypep, 2, symbol, 447 p2tv(kmutable_vectorp)); 448 /* (R7RS 3rd draft 6.3.6) make-vector */ 449 add_applicative(K, ground_env, "make-vector", make_vector, 0); 450 /* (R7RS 3rd draft 6.3.6) vector-length */ 451 add_applicative(K, ground_env, "vector-length", vector_length, 0); 452 453 /* (R7RS 3rd draft 6.3.6) vector-ref vector-set! */ 454 add_applicative(K, ground_env, "vector-ref", vector_ref, 0); 455 add_applicative(K, ground_env, "vector-set!", vector_setB, 0); 456 457 /* (R7RS 3rd draft 6.3.6) vector, vector->list, list->vector */ 458 add_applicative(K, ground_env, "vector", vector, 0); 459 add_applicative(K, ground_env, "vector->list", vector_to_list, 0); 460 add_applicative(K, ground_env, "list->vector", list_to_vector, 0); 461 462 /* ?.? vector-copy */ 463 add_applicative(K, ground_env, "vector-copy", vector_copy, 0); 464 465 /* ?.? vector->bytevector, bytevector->vector */ 466 add_applicative(K, ground_env, "vector->bytevector", 467 vector_to_bytevector, 0); 468 add_applicative(K, ground_env, "bytevector->vector", 469 bytevector_to_vector, 0); 470 471 /* ?.? vector->string, string->vector */ 472 /* in kgstrings.c */ 473 474 /* ?.? vector-copy! */ 475 add_applicative(K, ground_env, "vector-copy!", vector_copyB, 0); 476 477 /* ?.? vector-copy-partial */ 478 add_applicative(K, ground_env, "vector-copy-partial", 479 vector_copy_partial, 0); 480 /* ?.? vector-copy-partial! */ 481 add_applicative(K, ground_env, "vector-copy-partial!", 482 vector_copy_partialB, 0); 483 484 /* ?.? vector-fill! */ 485 add_applicative(K, ground_env, "vector-fill!", vector_fillB, 0); 486 487 /* ?.? vector->immutable-vector */ 488 add_applicative(K, ground_env, "vector->immutable-vector", 489 vector_to_immutable_vector, 0); 490 }