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