kgports.c (45262B)
1 /* 2 ** kgports.c 3 ** Ports features for the ground environment 4 ** See Copyright Notice in klisp.h 5 */ 6 7 #include <stdio.h> 8 #include <stdlib.h> 9 #include <stdbool.h> 10 #include <stdint.h> 11 #include <string.h> 12 13 #include "kstate.h" 14 #include "kobject.h" 15 #include "kport.h" 16 #include "kstring.h" 17 #include "ktable.h" 18 #include "kbytevector.h" 19 #include "kenvironment.h" 20 #include "kapplicative.h" 21 #include "koperative.h" 22 #include "kcontinuation.h" 23 #include "kpair.h" 24 #include "kerror.h" 25 #include "ksymbol.h" 26 #include "ktoken.h" 27 #include "kread.h" 28 #include "kwrite.h" 29 #include "kpair.h" 30 31 #include "kghelpers.h" 32 #include "kgports.h" 33 34 /* Continuations */ 35 void do_close_file_ret(klisp_State *K); 36 37 /* 15.1.1 port? */ 38 /* uses typep */ 39 40 /* 15.1.2 input-port?, output-port? */ 41 /* use ftypep */ 42 43 /* 15.1.? binary-port?, textual-port? */ 44 /* use ftypep */ 45 46 /* 15.1.? file-port?, string-port?, bytevector-port? */ 47 /* use ftypep */ 48 49 /* 15.1.? port-open? */ 50 /* uses ftyped_predp */ 51 52 /* uses ftyped_predp */ 53 54 /* 15.1.3 with-input-from-file, with-ouput-to-file */ 55 /* helper for with-i/o-from/to-file & call-with-i/o-file */ 56 void do_close_file_ret(klisp_State *K) 57 { 58 TValue *xparams = K->next_xparams; 59 TValue obj = K->next_value; 60 klisp_assert(ttisnil(K->next_env)); 61 /* 62 ** xparams[0]: port 63 */ 64 65 TValue port = xparams[0]; 66 kclose_port(K, port); 67 /* obj is the ret_val */ 68 kapply_cc(K, obj); 69 } 70 71 /* XXX: The report is incomplete here... for now use an empty environment, 72 the dynamic environment can be captured in the construction of the combiner 73 ASK John 74 */ 75 void with_file(klisp_State *K) 76 { 77 TValue *xparams = K->next_xparams; 78 TValue ptree = K->next_value; 79 TValue denv = K->next_env; 80 klisp_assert(ttisenvironment(K->next_env)); 81 bool writep = bvalue(xparams[1]); 82 TValue key = xparams[2]; 83 84 bind_2tp(K, ptree, "string", ttisstring, filename, 85 "combiner", ttiscombiner, comb); 86 87 TValue new_port = kmake_fport(K, filename, writep, false); 88 krooted_tvs_push(K, new_port); 89 /* make the continuation to close the file before returning */ 90 TValue new_cont = kmake_continuation(K, kget_cc(K), 91 do_close_file_ret, 1, new_port); 92 kset_cc(K, new_cont); /* cont implicitly rooted */ 93 krooted_tvs_pop(K); /* new_port is in cont */ 94 95 TValue op = kmake_operative(K, do_bind, 1, key); 96 krooted_tvs_push(K, op); 97 98 TValue args = klist(K, 2, new_port, comb); 99 100 krooted_tvs_pop(K); 101 102 /* even if we call with denv, do_bind calls comb in an empty env */ 103 /* XXX: what to pass for source info?? */ 104 ktail_call(K, op, args, denv); 105 } 106 107 /* 15.1.4 get-current-input-port, get-current-output-port */ 108 void get_current_port(klisp_State *K) 109 { 110 TValue *xparams = K->next_xparams; 111 TValue ptree = K->next_value; 112 TValue denv = K->next_env; 113 klisp_assert(ttisenvironment(K->next_env)); 114 /* 115 ** xparams[0]: symbol name 116 ** xparams[1]: dynamic key 117 */ 118 UNUSED(denv); 119 120 TValue key = xparams[1]; 121 122 check_0p(K, ptree); 123 124 /* can access directly, no need to call do_access */ 125 kapply_cc(K, kcdr(key)); 126 } 127 128 129 /* 15.1.5 open-input-file, open-output-file */ 130 /* 15.1.? open-binary-input-file, open-binary-output-file */ 131 void open_file(klisp_State *K) 132 { 133 TValue *xparams = K->next_xparams; 134 TValue ptree = K->next_value; 135 TValue denv = K->next_env; 136 klisp_assert(ttisenvironment(K->next_env)); 137 UNUSED(denv); 138 139 /* 140 ** xparams[0]: write? 141 ** xparams[1]: binary? 142 */ 143 bool writep = bvalue(xparams[0]); 144 bool binaryp = bvalue(xparams[1]); 145 146 bind_1tp(K, ptree, "string", ttisstring, filename); 147 148 TValue new_port = kmake_fport(K, filename, writep, binaryp); 149 kapply_cc(K, new_port); 150 } 151 152 /* 15.1.? open-input-string, open-output-string */ 153 /* 15.1.? open-input-bytevector, open-output-bytevector */ 154 void open_mport(klisp_State *K) 155 { 156 TValue *xparams = K->next_xparams; 157 TValue ptree = K->next_value; 158 TValue denv = K->next_env; 159 klisp_assert(ttisenvironment(K->next_env)); 160 /* 161 ** xparams[0]: write? 162 ** xparams[1]: binary? 163 */ 164 bool writep = bvalue(xparams[0]); 165 bool binaryp = bvalue(xparams[1]); 166 UNUSED(denv); 167 168 TValue buffer; 169 170 /* This is kinda ugly but... */ 171 if (writep) { 172 check_0p(K, ptree); 173 buffer = KINERT; 174 } else if (binaryp) { 175 bind_1tp(K, ptree, "bytevector", ttisbytevector, bb); 176 buffer = bb; 177 } else { 178 bind_1tp(K, ptree, "string", ttisstring, str); 179 buffer = str; 180 } 181 182 TValue new_port = kmake_mport(K, buffer, writep, binaryp); 183 kapply_cc(K, new_port); 184 } 185 186 /* 15.1.? open-output-string, open-output-bytevector */ 187 188 /* 15.1.6 close-input-file, close-output-file */ 189 void close_file(klisp_State *K) 190 { 191 TValue *xparams = K->next_xparams; 192 TValue ptree = K->next_value; 193 TValue denv = K->next_env; 194 klisp_assert(ttisenvironment(K->next_env)); 195 /* 196 ** xparams[0]: write? 197 */ 198 bool writep = bvalue(xparams[0]); 199 UNUSED(denv); 200 201 bind_1tp(K, ptree, "file port", ttisfport, port); 202 203 bool dir_ok = writep? kport_is_output(port) : kport_is_input(port); 204 205 if (dir_ok) { 206 kclose_port(K, port); 207 kapply_cc(K, KINERT); 208 } else { 209 klispE_throw_simple(K, "wrong input/output direction"); 210 return; 211 } 212 } 213 214 /* 15.1.? close-input-port, close-output-port, close-port */ 215 void close_port(klisp_State *K) 216 { 217 TValue *xparams = K->next_xparams; 218 TValue ptree = K->next_value; 219 TValue denv = K->next_env; 220 klisp_assert(ttisenvironment(K->next_env)); 221 /* 222 ** xparams[0]: read? 223 ** xparams[1]: write? 224 */ 225 bool readp = bvalue(xparams[0]); 226 bool writep = bvalue(xparams[1]); 227 UNUSED(denv); 228 229 bind_1tp(K, ptree, "port", ttisport, port); 230 231 bool dir_ok = !((writep && !kport_is_output(port)) || 232 (readp && !kport_is_input(port))); 233 234 if (dir_ok) { 235 kclose_port(K, port); 236 kapply_cc(K, KINERT); 237 } else { 238 klispE_throw_simple(K, "wrong input/output direction"); 239 return; 240 } 241 } 242 243 /* 15.1.? get-output-string, get-output-bytevector */ 244 void get_output_buffer(klisp_State *K) 245 { 246 TValue *xparams = K->next_xparams; 247 TValue ptree = K->next_value; 248 TValue denv = K->next_env; 249 klisp_assert(ttisenvironment(K->next_env)); 250 /* 251 ** xparams[0]: binary? 252 */ 253 bool binaryp = bvalue(xparams[0]); 254 UNUSED(denv); 255 bind_1tp(K, ptree, "port", ttismport, port); 256 257 if (binaryp && !kport_is_binary(port)) { 258 klispE_throw_simple(K, "the port should be a bytevector port"); 259 return; 260 } else if (!binaryp && !kport_is_textual(port)) { 261 klispE_throw_simple(K, "the port should be a string port"); 262 return; 263 } else if (!kport_is_output(port)) { 264 klispE_throw_simple(K, "the port should be an output port"); 265 return; 266 } 267 268 TValue ret = binaryp? 269 kbytevector_new_bs(K, 270 kbytevector_buf(kmport_buf(port)), 271 kmport_off(port)) : 272 kstring_new_bs(K, kstring_buf(kmport_buf(port)), kmport_off(port)); 273 kapply_cc(K, ret); 274 } 275 276 /* 15.1.7 read */ 277 void gread(klisp_State *K) 278 { 279 TValue *xparams = K->next_xparams; 280 TValue ptree = K->next_value; 281 TValue denv = K->next_env; 282 klisp_assert(ttisenvironment(K->next_env)); 283 UNUSED(xparams); 284 UNUSED(denv); 285 286 TValue port = ptree; 287 if (!get_opt_tpar(K, port, "port", ttisport)) { 288 port = kcdr(G(K)->kd_in_port_key); /* access directly */ 289 } 290 291 if (!kport_is_input(port)) { 292 klispE_throw_simple(K, "the port should be an input port"); 293 return; 294 } else if (!kport_is_textual(port)) { 295 klispE_throw_simple(K, "the port should be a textual port"); 296 return; 297 } else if (kport_is_closed(port)) { 298 klispE_throw_simple(K, "the port is already closed"); 299 return; 300 } 301 302 /* this may throw an error, that's ok */ 303 TValue obj = kread_from_port(K, port, true); /* read mutable pairs */ 304 kapply_cc(K, obj); 305 } 306 307 /* 15.1.8 write */ 308 void gwrite(klisp_State *K) 309 { 310 TValue *xparams = K->next_xparams; 311 TValue ptree = K->next_value; 312 TValue denv = K->next_env; 313 klisp_assert(ttisenvironment(K->next_env)); 314 UNUSED(xparams); 315 UNUSED(denv); 316 317 bind_al1tp(K, ptree, "any", anytype, obj, 318 port); 319 320 if (!get_opt_tpar(K, port, "port", ttisport)) { 321 port = kcdr(G(K)->kd_out_port_key); /* access directly */ 322 } 323 324 if (!kport_is_output(port)) { 325 klispE_throw_simple(K, "the port should be an output port"); 326 return; 327 } else if (!kport_is_textual(port)) { 328 klispE_throw_simple(K, "the port should be a textual port"); 329 return; 330 } else if (kport_is_closed(port)) { 331 klispE_throw_simple(K, "the port is already closed"); 332 return; 333 } 334 335 /* false: quote strings, escape chars */ 336 kwrite_display_to_port(K, port, obj, false); 337 kapply_cc(K, KINERT); 338 } 339 340 /* 15.1.? write-simple */ 341 void gwrite_simple(klisp_State *K) 342 { 343 TValue *xparams = K->next_xparams; 344 TValue ptree = K->next_value; 345 TValue denv = K->next_env; 346 klisp_assert(ttisenvironment(K->next_env)); 347 UNUSED(xparams); 348 UNUSED(denv); 349 350 bind_al1tp(K, ptree, "any", anytype, obj, 351 port); 352 353 if (!get_opt_tpar(K, port, "port", ttisport)) { 354 port = kcdr(G(K)->kd_out_port_key); /* access directly */ 355 } 356 357 if (!kport_is_output(port)) { 358 klispE_throw_simple(K, "the port should be an output port"); 359 return; 360 } else if (!kport_is_textual(port)) { 361 klispE_throw_simple(K, "the port should be a textual port"); 362 return; 363 } else if (kport_is_closed(port)) { 364 klispE_throw_simple(K, "the port is already closed"); 365 return; 366 } 367 368 kwrite_simple_to_port(K, port, obj); 369 kapply_cc(K, KINERT); 370 } 371 372 /* 15.1.? eof-object? */ 373 /* uses typep */ 374 375 /* 15.1.? newline */ 376 void newline(klisp_State *K) 377 { 378 TValue *xparams = K->next_xparams; 379 TValue ptree = K->next_value; 380 TValue denv = K->next_env; 381 klisp_assert(ttisenvironment(K->next_env)); 382 UNUSED(xparams); 383 UNUSED(denv); 384 385 TValue port = ptree; 386 if (!get_opt_tpar(K, port, "port", ttisport)) { 387 port = kcdr(G(K)->kd_out_port_key); /* access directly */ 388 } 389 390 if (!kport_is_output(port)) { 391 klispE_throw_simple(K, "the port should be an output port"); 392 return; 393 } else if (!kport_is_textual(port)) { 394 klispE_throw_simple(K, "the port should be a textual port"); 395 return; 396 } else if (kport_is_closed(port)) { 397 klispE_throw_simple(K, "the port is already closed"); 398 return; 399 } 400 401 kwrite_newline_to_port(K, port); 402 kapply_cc(K, KINERT); 403 } 404 405 /* 15.1.? write-char */ 406 void write_char(klisp_State *K) 407 { 408 TValue *xparams = K->next_xparams; 409 TValue ptree = K->next_value; 410 TValue denv = K->next_env; 411 klisp_assert(ttisenvironment(K->next_env)); 412 UNUSED(xparams); 413 UNUSED(denv); 414 415 bind_al1tp(K, ptree, "char", ttischar, ch, 416 port); 417 418 if (!get_opt_tpar(K, port, "port", ttisport)) { 419 port = kcdr(G(K)->kd_out_port_key); /* access directly */ 420 } 421 422 if (!kport_is_output(port)) { 423 klispE_throw_simple(K, "the port should be an output port"); 424 return; 425 } else if (!kport_is_textual(port)) { 426 klispE_throw_simple(K, "the port should be a textual port"); 427 return; 428 } else if (kport_is_closed(port)) { 429 klispE_throw_simple(K, "the port is already closed"); 430 return; 431 } 432 433 kwrite_char_to_port(K, port, ch); 434 kapply_cc(K, KINERT); 435 } 436 437 /* Helper for read-char and peek-char */ 438 void read_peek_char(klisp_State *K) 439 { 440 TValue *xparams = K->next_xparams; 441 TValue ptree = K->next_value; 442 TValue denv = K->next_env; 443 klisp_assert(ttisenvironment(K->next_env)); 444 /* 445 ** xparams[0]: ret-char-after-readp 446 */ 447 UNUSED(denv); 448 449 bool ret_charp = bvalue(xparams[0]); 450 451 TValue port = ptree; 452 if (!get_opt_tpar(K, port, "port", ttisport)) { 453 port = kcdr(G(K)->kd_in_port_key); /* access directly */ 454 } 455 456 if (!kport_is_input(port)) { 457 klispE_throw_simple(K, "the port should be an input port"); 458 return; 459 } else if (!kport_is_textual(port)) { 460 klispE_throw_simple(K, "the port should be a textual port"); 461 return; 462 } else if (kport_is_closed(port)) { 463 klispE_throw_simple(K, "the port is already closed"); 464 return; 465 } 466 467 TValue obj = kread_peek_char_from_port(K, port, ret_charp); 468 kapply_cc(K, obj); 469 } 470 471 472 /* 15.1.? read-char */ 473 /* uses read_peek_char */ 474 475 /* 15.1.? peek-char */ 476 /* uses read_peek_char */ 477 478 /* 15.1.? char-ready? */ 479 /* XXX: this always return #t, proper behaviour requires platform 480 specific code (probably select for posix & a thread for windows 481 (at least for files & consoles, I think pipes and sockets may 482 have something) */ 483 void char_readyp(klisp_State *K) 484 { 485 TValue *xparams = K->next_xparams; 486 TValue ptree = K->next_value; 487 TValue denv = K->next_env; 488 klisp_assert(ttisenvironment(K->next_env)); 489 UNUSED(xparams); 490 UNUSED(denv); 491 492 TValue port = ptree; 493 if (!get_opt_tpar(K, port, "port", ttisport)) { 494 port = kcdr(G(K)->kd_in_port_key); /* access directly */ 495 } 496 497 if (!kport_is_input(port)) { 498 klispE_throw_simple(K, "the port should be an input port"); 499 return; 500 } else if (!kport_is_textual(port)) { 501 klispE_throw_simple(K, "the port should be a textual port"); 502 return; 503 } else if (kport_is_closed(port)) { 504 klispE_throw_simple(K, "the port is already closed"); 505 return; 506 } 507 508 /* TODO: check if there are pending chars */ 509 kapply_cc(K, KTRUE); 510 } 511 512 /* 15.1.? write-u8 */ 513 void write_u8(klisp_State *K) 514 { 515 TValue *xparams = K->next_xparams; 516 TValue ptree = K->next_value; 517 TValue denv = K->next_env; 518 klisp_assert(ttisenvironment(K->next_env)); 519 UNUSED(xparams); 520 UNUSED(denv); 521 522 bind_al1tp(K, ptree, "u8", ttisu8, u8, port); 523 524 if (!get_opt_tpar(K, port, "port", ttisport)) { 525 port = kcdr(G(K)->kd_out_port_key); /* access directly */ 526 } 527 528 if (!kport_is_output(port)) { 529 klispE_throw_simple(K, "the port should be an output port"); 530 return; 531 } else if (!kport_is_binary(port)) { 532 klispE_throw_simple(K, "the port should be a binary port"); 533 return; 534 } else if (kport_is_closed(port)) { 535 klispE_throw_simple(K, "the port is already closed"); 536 return; 537 } 538 539 kwrite_u8_to_port(K, port, u8); 540 kapply_cc(K, KINERT); 541 } 542 543 /* Helper for read-u8 and peek-u8 */ 544 void read_peek_u8(klisp_State *K) 545 { 546 TValue *xparams = K->next_xparams; 547 TValue ptree = K->next_value; 548 TValue denv = K->next_env; 549 klisp_assert(ttisenvironment(K->next_env)); 550 /* 551 ** xparams[0]: ret-u8-after-readp 552 */ 553 UNUSED(denv); 554 555 bool ret_u8p = bvalue(xparams[0]); 556 557 TValue port = ptree; 558 if (!get_opt_tpar(K, port, "port", ttisport)) { 559 port = kcdr(G(K)->kd_in_port_key); /* access directly */ 560 } 561 562 if (!kport_is_input(port)) { 563 klispE_throw_simple(K, "the port should be an input port"); 564 return; 565 } else if (!kport_is_binary(port)) { 566 klispE_throw_simple(K, "the port should be a binary port"); 567 return; 568 } else if (kport_is_closed(port)) { 569 klispE_throw_simple(K, "the port is already closed"); 570 return; 571 } 572 573 TValue obj = kread_peek_u8_from_port(K, port, ret_u8p); 574 kapply_cc(K, obj); 575 } 576 577 578 /* 15.1.? read-u8 */ 579 /* uses read_peek_u8 */ 580 581 /* 15.1.? peek-u8 */ 582 /* uses read_peek_u8 */ 583 584 /* 15.1.? u8-ready? */ 585 /* XXX: this always return #t, proper behaviour requires platform 586 specific code (probably select for posix & a thread for windows 587 (at least for files & consoles, I think pipes and sockets may 588 have something) */ 589 void u8_readyp(klisp_State *K) 590 { 591 TValue *xparams = K->next_xparams; 592 TValue ptree = K->next_value; 593 TValue denv = K->next_env; 594 klisp_assert(ttisenvironment(K->next_env)); 595 UNUSED(xparams); 596 UNUSED(denv); 597 598 TValue port = ptree; 599 if (!get_opt_tpar(K, port, "port", ttisport)) { 600 port = kcdr(G(K)->kd_in_port_key); /* access directly */ 601 } 602 603 if (!kport_is_input(port)) { 604 klispE_throw_simple(K, "the port should be an input port"); 605 return; 606 } else if (!kport_is_binary(port)) { 607 klispE_throw_simple(K, "the port should be a binary port"); 608 return; 609 } else if (kport_is_closed(port)) { 610 klispE_throw_simple(K, "the port is already closed"); 611 return; 612 } 613 614 /* TODO: check if there are pending chars */ 615 kapply_cc(K, KTRUE); 616 } 617 618 /* 15.2.1 call-with-input-file, call-with-output-file */ 619 /* XXX: The report is incomplete here... for now use an empty environment, 620 the dynamic environment can be captured in the construction of the combiner 621 ASK John 622 */ 623 void call_with_file(klisp_State *K) 624 { 625 TValue *xparams = K->next_xparams; 626 TValue ptree = K->next_value; 627 TValue denv = K->next_env; 628 klisp_assert(ttisenvironment(K->next_env)); 629 bool writep = bvalue(xparams[1]); 630 UNUSED(denv); 631 632 bind_2tp(K, ptree, "string", ttisstring, filename, 633 "combiner", ttiscombiner, comb); 634 635 TValue new_port = kmake_fport(K, filename, writep, false); 636 krooted_tvs_push(K, new_port); 637 /* make the continuation to close the file before returning */ 638 TValue new_cont = kmake_continuation(K, kget_cc(K), 639 do_close_file_ret, 1, new_port); 640 kset_cc(K, new_cont); /* implicit rooting */ 641 krooted_tvs_pop(K); /* new_port is in new_cont */ 642 TValue empty_env = kmake_empty_environment(K); 643 krooted_tvs_push(K, empty_env); 644 TValue expr = klist(K, 2, comb, new_port); 645 646 krooted_tvs_pop(K); 647 ktail_eval(K, expr, empty_env); 648 } 649 650 /* helpers for load */ 651 652 /* interceptor for errors during reading */ 653 void do_int_close_file(klisp_State *K) 654 { 655 TValue *xparams = K->next_xparams; 656 TValue ptree = K->next_value; 657 TValue denv = K->next_env; 658 klisp_assert(ttisenvironment(K->next_env)); 659 /* 660 ** xparams[0]: port 661 */ 662 UNUSED(denv); 663 664 TValue port = xparams[0]; 665 /* ptree is (object divert) */ 666 TValue error_obj = kcar(ptree); 667 kclose_port(K, port); 668 /* pass the error along after closing the port */ 669 kapply_cc(K, error_obj); 670 } 671 672 673 /* 674 ** guarded continuation making for read seq 675 */ 676 677 /* GC: assumes parent & port are rooted */ 678 TValue make_guarded_read_cont(klisp_State *K, TValue parent, TValue port) 679 { 680 /* create the guard to close file after read errors */ 681 TValue exit_int = kmake_operative(K, do_int_close_file, 682 1, port); 683 krooted_tvs_push(K, exit_int); 684 TValue exit_guard = kcons(K, G(K)->error_cont, exit_int); 685 krooted_tvs_pop(K); /* alread in guard */ 686 krooted_tvs_push(K, exit_guard); 687 TValue exit_guards = kcons(K, exit_guard, KNIL); 688 krooted_tvs_pop(K); /* alread in guards */ 689 krooted_tvs_push(K, exit_guards); 690 691 TValue entry_guards = KNIL; 692 693 /* this is needed for interception code */ 694 TValue env = kmake_empty_environment(K); 695 krooted_tvs_push(K, env); 696 TValue outer_cont = kmake_continuation(K, parent, 697 do_pass_value, 2, entry_guards, env); 698 kset_outer_cont(outer_cont); 699 krooted_tvs_push(K, outer_cont); 700 TValue inner_cont = kmake_continuation(K, outer_cont, 701 do_pass_value, 2, exit_guards, env); 702 kset_inner_cont(inner_cont); 703 krooted_tvs_pop(K); krooted_tvs_pop(K); krooted_tvs_pop(K); 704 return inner_cont; 705 } 706 707 /* 15.2.2 load */ 708 /* TEMP: this isn't yet defined in the report, but this seems pretty 709 a sane way to do it: open the file whose name is passed 710 as only parameter. read all the expressions in file as by read and 711 accumulate them in a list. close the file. eval ($sequence . list) in 712 the dynamic environment of the call to load. return #inert. If there is 713 any error during reading, close the file and return that error. 714 This is consistent with the report description of the load-module 715 applicative. 716 ASK John: maybe we should return the result of the last expression. 717 */ 718 void load(klisp_State *K) 719 { 720 TValue *xparams = K->next_xparams; 721 TValue ptree = K->next_value; 722 TValue denv = K->next_env; 723 klisp_assert(ttisenvironment(K->next_env)); 724 UNUSED(xparams); 725 bind_1tp(K, ptree, "string", ttisstring, filename); 726 727 /* the reads must be guarded to close the file if there is some error 728 this continuation also will return inert after the evaluation of the 729 last expression is done */ 730 TValue port = kmake_fport(K, filename, false, false); 731 krooted_tvs_push(K, port); 732 733 TValue inert_cont = kmake_continuation(K, kget_cc(K), do_return_value, 1, 734 KINERT); 735 736 krooted_tvs_push(K, inert_cont); 737 738 TValue guarded_cont = make_guarded_read_cont(K, kget_cc(K), port); 739 /* this will be used later, but contruct it now to use the 740 current continuation as parent 741 GC: root this obj */ 742 kset_cc(K, guarded_cont); /* implicit rooting */ 743 /* any error will close the port */ 744 TValue ls = kread_list_from_port(K, port, false); /* immutable pairs */ 745 746 /* now the sequence of expresions should be evaluated in denv 747 and #inert returned after all are done */ 748 kset_cc(K, inert_cont); /* implicit rooting */ 749 krooted_tvs_pop(K); /* already rooted */ 750 751 752 if (ttisnil(ls)) { 753 krooted_tvs_pop(K); /* port */ 754 kapply_cc(K, KINERT); 755 } else { 756 TValue tail = kcdr(ls); 757 if (ttispair(tail)) { 758 krooted_tvs_push(K, ls); 759 TValue new_cont = kmake_continuation(K, kget_cc(K), 760 do_seq, 2, tail, denv); 761 kset_cc(K, new_cont); 762 #if KTRACK_SI 763 /* put the source info of the list including the element 764 that we are about to evaluate */ 765 kset_source_info(K, new_cont, ktry_get_si(K, ls)); 766 #endif 767 krooted_tvs_pop(K); /* ls */ 768 } 769 krooted_tvs_pop(K); /* port */ 770 ktail_eval(K, kcar(ls), denv); 771 } 772 } 773 774 /* Helpers for require */ 775 static bool readable(const char *filename) { 776 FILE *f = fopen(filename, "r"); /* try to open file */ 777 if (f == NULL) return false; /* open failed */ 778 fclose(f); 779 return true; 780 } 781 782 /* Path can't/shouldn't contain embedded zeros */ 783 static const char *get_next_template(klisp_State *K, const char *path, 784 TValue *next) { 785 const char *l; 786 while (*path == *KLISP_PATHSEP) path++; /* skip separators */ 787 if (*path == '\0') return NULL; /* no more templates */ 788 l = strchr(path, *KLISP_PATHSEP); /* find next separator */ 789 if (l == NULL) l = path + strlen(path); 790 *next = kstring_new_bs(K, path, l-path); /* template */ 791 return l; /* pointer to the end of the template */ 792 } 793 794 /* no strings should contains embedded zeroes */ 795 static TValue str_sub(klisp_State *K, TValue s, TValue p, TValue r) 796 { 797 const char *sp = kstring_buf(s); 798 const char *pp = kstring_buf(p); 799 const char *rp = kstring_buf(r); 800 801 uint32_t size = kstring_size(s); 802 uint32_t psize = kstring_size(p); 803 uint32_t rsize = kstring_size(r); 804 int32_t diff_size = rsize - psize; 805 806 const char *wild; 807 808 /* first calculate needed size */ 809 while ((wild = strstr(sp, pp)) != NULL) { 810 size += diff_size; 811 sp = wild + psize; 812 } 813 814 /* now construct result buffer and fill it */ 815 TValue res = kstring_new_s(K, size); 816 char *resp = kstring_buf(res); 817 sp = kstring_buf(s); 818 while ((wild = strstr(sp, pp)) != NULL) { 819 ptrdiff_t l = wild - sp; 820 memcpy(resp, sp, l); 821 resp += l; 822 memcpy(resp, rp, rsize); 823 resp += rsize; 824 sp = wild + psize; 825 } 826 strcpy(resp, sp); /* the size was calculated beforehand */ 827 return res; 828 } 829 830 static TValue find_file (klisp_State *K, TValue name, TValue pname) { 831 /* not used in klisp */ 832 /* name = luaL_gsub(L, name, ".", LUA_DIRSEP); */ 833 /* lua_getfield(L, LUA_ENVIRONINDEX, pname); */ 834 klisp_assert(ttisstring(name) && !kstring_emptyp(name)); 835 const char *path = kstring_buf(pname); 836 TValue next = G(K)->empty_string; 837 krooted_vars_push(K, &next); 838 TValue wild = kstring_new_b(K, KLISP_PATH_MARK); 839 krooted_tvs_push(K, wild); 840 841 while ((path = get_next_template(K, path, &next)) != NULL) { 842 next = str_sub(K, next, wild, name); 843 if (readable(kstring_buf(next))) { /* does file exist and is readable? */ 844 krooted_tvs_pop(K); 845 krooted_vars_pop(K); 846 return next; /* return that file name */ 847 } 848 } 849 850 krooted_tvs_pop(K); 851 krooted_vars_pop(K); 852 return G(K)->empty_string; /* return empty_string */ 853 } 854 855 /* XXX lock? */ 856 /* ?.? require */ 857 /* 858 ** require is like load except that: 859 ** - require first checks to see if the file was already required 860 ** and if so, doesnt' do anything 861 ** - require looks for the named file in a number of locations 862 ** configurable via env var KLISP_PATH 863 ** - When/if the file is found, evaluation happens in an initially 864 ** standard environment 865 */ 866 void require(klisp_State *K) 867 { 868 TValue *xparams = K->next_xparams; 869 TValue ptree = K->next_value; 870 TValue denv = K->next_env; 871 klisp_assert(ttisenvironment(K->next_env)); 872 UNUSED(denv); 873 UNUSED(xparams); 874 bind_1tp(K, ptree, "string", ttisstring, name); 875 876 if (kstring_emptyp(name)) { 877 klispE_throw_simple(K, "Empty name"); 878 return; 879 } 880 /* search for the named file in the table of already 881 required files. 882 N.B. this will be fooled if the same file is accessed 883 through different names */ 884 TValue saved_name = kstring_immutablep(name)? name : 885 kstring_new_bs_imm(K, kstring_buf(name), kstring_size(name)); 886 887 const TValue *node = klispH_getstr(tv2table(G(K)->require_table), 888 tv2str(saved_name)); 889 if (!ttisfree(*node)) { 890 /* was required already, nothing to be done */ 891 kapply_cc(K, KINERT); 892 } 893 894 krooted_tvs_push(K, saved_name); 895 TValue filename = G(K)->empty_string; 896 krooted_vars_push(K, &filename); 897 filename = find_file(K, name, G(K)->require_path); 898 899 if (kstring_emptyp(filename)) { 900 klispE_throw_simple_with_irritants(K, "Not found", 1, name); 901 return; 902 } 903 904 /* the file was found, save it in the table */ 905 /* MAYBE the name should be saved in the table only if no error 906 occured... but that could lead to loops if the file is 907 required recursively. A third option would be to record the 908 sate of the require in the table, so we could have: error, required, 909 requiring, etc */ 910 *(klispH_setstr(K, tv2table(G(K)->require_table), tv2str(saved_name))) = 911 KTRUE; 912 krooted_tvs_pop(K); /* saved_name no longer necessary */ 913 914 /* the reads must be guarded to close the file if there is some error 915 this continuation also will return inert after the evaluation of the 916 last expression is done */ 917 TValue port = kmake_fport(K, filename, false, false); 918 krooted_tvs_push(K, port); 919 krooted_vars_pop(K); /* filename already rooted */ 920 921 TValue inert_cont = kmake_continuation(K, kget_cc(K), do_return_value, 1, 922 KINERT); 923 924 krooted_tvs_push(K, inert_cont); 925 926 TValue guarded_cont = make_guarded_read_cont(K, kget_cc(K), port); 927 /* this will be used later, but contruct it now to use the 928 current continuation as parent 929 GC: root this obj */ 930 kset_cc(K, guarded_cont); /* implicit rooting */ 931 /* any error will close the port */ 932 TValue ls = kread_list_from_port(K, port, false); /* immutable pairs */ 933 934 /* now the sequence of expresions should be evaluated in a 935 standard environment and #inert returned after all are done */ 936 kset_cc(K, inert_cont); /* implicit rooting */ 937 krooted_tvs_pop(K); /* already rooted */ 938 939 if (ttisnil(ls)) { 940 krooted_tvs_pop(K); /* port */ 941 kapply_cc(K, KINERT); 942 } else { 943 TValue tail = kcdr(ls); 944 /* std environments have hashtable for bindings */ 945 TValue env = kmake_table_environment(K, G(K)->ground_env); 946 if (ttispair(tail)) { 947 krooted_tvs_push(K, ls); 948 krooted_tvs_push(K, env); 949 TValue new_cont = kmake_continuation(K, kget_cc(K), 950 do_seq, 2, tail, env); 951 kset_cc(K, new_cont); 952 #if KTRACK_SI 953 /* put the source info of the list including the element 954 that we are about to evaluate */ 955 kset_source_info(K, new_cont, ktry_get_si(K, ls)); 956 #endif 957 krooted_tvs_pop(K); /* env */ 958 krooted_tvs_pop(K); /* ls */ 959 } 960 krooted_tvs_pop(K); /* port */ 961 ktail_eval(K, kcar(ls), env); 962 } 963 } 964 965 /* XXX lock? */ 966 /* ?.? registered-requirement? */ 967 void registered_requirementP(klisp_State *K) 968 { 969 bind_1tp(K, K->next_value, "string", ttisstring, name); 970 if (kstring_emptyp(name)) { 971 klispE_throw_simple(K, "Empty name"); 972 return; 973 } 974 /* search for the named file in the table of already 975 required files. 976 N.B. this will be fooled if the same file is accessed 977 through different names */ 978 TValue saved_name = kstring_immutablep(name)? name : 979 kstring_new_bs_imm(K, kstring_buf(name), kstring_size(name)); 980 981 const TValue *node = klispH_getstr(tv2table(G(K)->require_table), 982 tv2str(saved_name)); 983 kapply_cc(K, ttisfree(*node)? KFALSE : KTRUE); 984 } 985 986 /* XXX lock? */ 987 void register_requirementB(klisp_State *K) 988 { 989 bind_1tp(K, K->next_value, "string", ttisstring, name); 990 if (kstring_emptyp(name)) { 991 klispE_throw_simple(K, "Empty name"); 992 return; 993 } 994 TValue saved_name = kstring_immutablep(name)? name : 995 kstring_new_bs_imm(K, kstring_buf(name), kstring_size(name)); 996 997 TValue *node = klispH_setstr(K, tv2table(G(K)->require_table), 998 tv2str(saved_name)); 999 1000 /* throw error if already registered */ 1001 if (!ttisfree(*node)) { 1002 klispE_throw_simple_with_irritants(K, "Name already registered", 1003 1, name); 1004 return; 1005 } 1006 1007 *node = KTRUE; 1008 kapply_cc(K, KINERT); 1009 } 1010 1011 /* XXX lock? */ 1012 void unregister_requirementB(klisp_State *K) 1013 { 1014 bind_1tp(K, K->next_value, "string", ttisstring, name); 1015 if (kstring_emptyp(name)) { 1016 klispE_throw_simple(K, "Empty name"); 1017 return; 1018 } 1019 TValue saved_name = kstring_immutablep(name)? name : 1020 kstring_new_bs_imm(K, kstring_buf(name), kstring_size(name)); 1021 1022 TValue *node = klispH_setstr(K, tv2table(G(K)->require_table), 1023 tv2str(saved_name)); 1024 1025 /* throw error if not registered */ 1026 if (ttisfree(*node)) { 1027 klispE_throw_simple_with_irritants(K, "Unregistered name", 1, name); 1028 return; 1029 } 1030 1031 *node = KFREE; 1032 kapply_cc(K, KINERT); 1033 } 1034 1035 /* XXX lock? */ 1036 /* will throw an error if not found */ 1037 void find_required_filename(klisp_State *K) 1038 { 1039 bind_1tp(K, K->next_value, "string", ttisstring, name); 1040 if (kstring_emptyp(name)) { 1041 klispE_throw_simple(K, "Empty name"); 1042 return; 1043 } 1044 TValue filename = find_file(K, name, G(K)->require_path); 1045 1046 if (kstring_emptyp(filename)) { 1047 klispE_throw_simple_with_irritants(K, "Not found", 1, name); 1048 return; 1049 } 1050 kapply_cc(K, filename); 1051 } 1052 1053 /* 15.2.3 get-module */ 1054 void get_module(klisp_State *K) 1055 { 1056 TValue *xparams = K->next_xparams; 1057 TValue ptree = K->next_value; 1058 TValue denv = K->next_env; 1059 klisp_assert(ttisenvironment(K->next_env)); 1060 UNUSED(xparams); 1061 UNUSED(denv); 1062 bind_al1tp(K, ptree, "string", ttisstring, filename, 1063 maybe_env); 1064 1065 TValue port = kmake_fport(K, filename, false, false); 1066 krooted_tvs_push(K, port); 1067 1068 /* std environments have hashtable for bindings */ 1069 TValue env = kmake_table_environment(K, G(K)->ground_env); 1070 // TValue env = kmake_environment(K, G(K)->ground_env); 1071 krooted_tvs_push(K, env); 1072 1073 if (get_opt_tpar(K, maybe_env, "environment", ttisenvironment)) { 1074 kadd_binding(K, env, G(K)->module_params_sym, maybe_env); 1075 } 1076 1077 TValue ret_env_cont = kmake_continuation(K, kget_cc(K), do_return_value, 1078 1, env); 1079 krooted_tvs_pop(K); /* env alread in cont */ 1080 krooted_tvs_push(K, ret_env_cont); 1081 1082 /* the reads must be guarded to close the file if there is some error 1083 this continuation also will return inert after the evaluation of the 1084 last expression is done */ 1085 TValue guarded_cont = make_guarded_read_cont(K, kget_cc(K), port); 1086 kset_cc(K, guarded_cont); /* implicit roooting */ 1087 1088 1089 /* any error will close the port */ 1090 TValue ls = kread_list_from_port(K, port, false); /* use immutable pairs */ 1091 1092 /* now the sequence of expresions should be evaluated in the created env 1093 and the environment returned after all are done */ 1094 kset_cc(K, ret_env_cont); /* implicit rooting */ 1095 krooted_tvs_pop(K); /* implicitly rooted */ 1096 1097 if (ttisnil(ls)) { 1098 krooted_tvs_pop(K); /* port */ 1099 kapply_cc(K, KINERT); 1100 } else { 1101 TValue tail = kcdr(ls); 1102 if (ttispair(tail)) { 1103 krooted_tvs_push(K, ls); 1104 TValue new_cont = kmake_continuation(K, kget_cc(K), 1105 do_seq, 2, tail, env); 1106 kset_cc(K, new_cont); 1107 #if KTRACK_SI 1108 /* put the source info of the list including the element 1109 that we are about to evaluate */ 1110 kset_source_info(K, new_cont, ktry_get_si(K, ls)); 1111 #endif 1112 krooted_tvs_pop(K); 1113 } 1114 krooted_tvs_pop(K); /* port */ 1115 ktail_eval(K, kcar(ls), env); 1116 } 1117 } 1118 1119 /* 15.2.? display */ 1120 void display(klisp_State *K) 1121 { 1122 TValue *xparams = K->next_xparams; 1123 TValue ptree = K->next_value; 1124 TValue denv = K->next_env; 1125 klisp_assert(ttisenvironment(K->next_env)); 1126 UNUSED(xparams); 1127 UNUSED(denv); 1128 1129 bind_al1tp(K, ptree, "any", anytype, obj, 1130 port); 1131 1132 if (!get_opt_tpar(K, port, "port", ttisport)) { 1133 port = kcdr(G(K)->kd_out_port_key); /* access directly */ 1134 } 1135 1136 if (!kport_is_output(port)) { 1137 klispE_throw_simple(K, "the port should be an output port"); 1138 return; 1139 } else if (!kport_is_textual(port)) { 1140 klispE_throw_simple(K, "the port should be a textual port"); 1141 return; 1142 } else if (kport_is_closed(port)) { 1143 klispE_throw_simple(K, "the port is already closed"); 1144 return; 1145 } 1146 1147 /* true: don't quote strings, don't escape chars */ 1148 kwrite_display_to_port(K, port, obj, true); 1149 kapply_cc(K, KINERT); 1150 } 1151 1152 void read_line(klisp_State *K) 1153 { 1154 TValue *xparams = K->next_xparams; 1155 TValue ptree = K->next_value; 1156 TValue denv = K->next_env; 1157 klisp_assert(ttisenvironment(K->next_env)); 1158 1159 UNUSED(xparams); 1160 UNUSED(denv); 1161 1162 TValue port = ptree; 1163 if (!get_opt_tpar(K, port, "port", ttisport)) { 1164 port = kcdr(G(K)->kd_in_port_key); /* access directly */ 1165 } 1166 1167 if (!kport_is_input(port)) { 1168 klispE_throw_simple(K, "the port should be an input port"); 1169 return; 1170 } else if (!kport_is_textual(port)) { 1171 klispE_throw_simple(K, "the port should be a textual port"); 1172 return; 1173 } else if (kport_is_closed(port)) { 1174 klispE_throw_simple(K, "the port is already closed"); 1175 return; 1176 } 1177 1178 TValue obj = kread_line_from_port(K, port); 1179 kapply_cc(K, obj); 1180 } 1181 1182 /* 15.1.? flush-output-port */ 1183 void flush(klisp_State *K) 1184 { 1185 TValue *xparams = K->next_xparams; 1186 TValue ptree = K->next_value; 1187 TValue denv = K->next_env; 1188 klisp_assert(ttisenvironment(K->next_env)); 1189 UNUSED(xparams); 1190 UNUSED(denv); 1191 1192 TValue port = ptree; 1193 1194 if (!get_opt_tpar(K, port, "port", ttisport)) { 1195 port = kcdr(G(K)->kd_out_port_key); /* access directly */ 1196 } 1197 1198 if (!kport_is_output(port)) { 1199 klispE_throw_simple(K, "the port should be an output port"); 1200 return; 1201 } 1202 1203 if (kport_is_closed(port)) { 1204 klispE_throw_simple(K, "the port is already closed"); 1205 return; 1206 } 1207 1208 kwrite_flush_port(K, port); 1209 kapply_cc(K, KINERT); 1210 } 1211 1212 /* init ground */ 1213 void kinit_ports_ground_env(klisp_State *K) 1214 { 1215 /* 1216 ** Some of these are from r7rs scheme 1217 */ 1218 1219 TValue ground_env = G(K)->ground_env; 1220 TValue symbol, value; 1221 1222 /* 15.1.1 port? */ 1223 add_applicative(K, ground_env, "port?", ftypep, 2, symbol, 1224 p2tv(kportp)); 1225 /* 15.1.2 input-port?, output-port? */ 1226 add_applicative(K, ground_env, "input-port?", ftypep, 2, symbol, 1227 p2tv(kinput_portp)); 1228 add_applicative(K, ground_env, "output-port?", ftypep, 2, symbol, 1229 p2tv(koutput_portp)); 1230 /* 15.1.? binary-port?, textual-port? */ 1231 add_applicative(K, ground_env, "binary-port?", ftypep, 2, symbol, 1232 p2tv(kbinary_portp)); 1233 add_applicative(K, ground_env, "textual-port?", ftypep, 2, symbol, 1234 p2tv(ktextual_portp)); 1235 /* 15.1.2 file-port?, string-port?, bytevector-port? */ 1236 add_applicative(K, ground_env, "file-port?", ftypep, 2, symbol, 1237 p2tv(kfile_portp)); 1238 add_applicative(K, ground_env, "string-port?", ftypep, 2, symbol, 1239 p2tv(kstring_portp)); 1240 add_applicative(K, ground_env, "bytevector-port?", ftypep, 2, symbol, 1241 p2tv(kbytevector_portp)); 1242 /* 15.1.? port-open? */ 1243 add_applicative(K, ground_env, "port-open?", ftyped_predp, 3, symbol, 1244 p2tv(kportp), p2tv(kport_openp)); 1245 1246 /* 15.1.3 with-input-from-file, with-ouput-to-file */ 1247 /* 15.1.? with-error-to-file */ 1248 add_applicative(K, ground_env, "with-input-from-file", with_file, 1249 3, symbol, b2tv(false), G(K)->kd_in_port_key); 1250 add_applicative(K, ground_env, "with-output-to-file", with_file, 1251 3, symbol, b2tv(true), G(K)->kd_out_port_key); 1252 add_applicative(K, ground_env, "with-error-to-file", with_file, 1253 3, symbol, b2tv(true), G(K)->kd_error_port_key); 1254 /* 15.1.4 get-current-input-port, get-current-output-port */ 1255 /* 15.1.? get-current-error-port */ 1256 add_applicative(K, ground_env, "get-current-input-port", get_current_port, 1257 2, symbol, G(K)->kd_in_port_key); 1258 add_applicative(K, ground_env, "get-current-output-port", get_current_port, 1259 2, symbol, G(K)->kd_out_port_key); 1260 add_applicative(K, ground_env, "get-current-error-port", get_current_port, 1261 2, symbol, G(K)->kd_error_port_key); 1262 /* 15.1.5 open-input-file, open-output-file */ 1263 add_applicative(K, ground_env, "open-input-file", open_file, 2, 1264 b2tv(false), b2tv(false)); 1265 add_applicative(K, ground_env, "open-output-file", open_file, 2, 1266 b2tv(true), b2tv(false)); 1267 /* 15.1.? open-binary-input-file, open-binary-output-file */ 1268 add_applicative(K, ground_env, "open-binary-input-file", open_file, 2, 1269 b2tv(false), b2tv(true)); 1270 add_applicative(K, ground_env, "open-binary-output-file", open_file, 2, 1271 b2tv(true), b2tv(true)); 1272 /* 15.1.? open-input-string, open-output-string */ 1273 /* 15.1.? open-input-bytevector, open-output-bytevector */ 1274 add_applicative(K, ground_env, "open-input-string", open_mport, 2, 1275 b2tv(false), b2tv(false)); 1276 add_applicative(K, ground_env, "open-output-string", open_mport, 2, 1277 b2tv(true), b2tv(false)); 1278 add_applicative(K, ground_env, "open-input-bytevector", open_mport, 2, 1279 b2tv(false), b2tv(true)); 1280 add_applicative(K, ground_env, "open-output-bytevector", open_mport, 2, 1281 b2tv(true), b2tv(true)); 1282 1283 /* 15.1.6 close-input-file, close-output-file */ 1284 /* ASK John: should this be called close-input-port & close-ouput-port 1285 like in r5rs? */ 1286 add_applicative(K, ground_env, "close-input-file", close_file, 1, 1287 b2tv(false)); 1288 add_applicative(K, ground_env, "close-output-file", close_file, 1, 1289 b2tv(true)); 1290 /* 15.1.? Use the r7rs names, this has more sense in the face of 1291 the different port types available in klisp */ 1292 add_applicative(K, ground_env, "close-input-port", close_port, 2, 1293 b2tv(true), b2tv(false)); 1294 add_applicative(K, ground_env, "close-output-port", close_port, 2, 1295 b2tv(false), b2tv(true)); 1296 add_applicative(K, ground_env, "close-port", close_port, 2, 1297 b2tv(false), b2tv(false)); 1298 1299 /* 15.1.? get-output-string, get-output-bytevector */ 1300 add_applicative(K, ground_env, "get-output-string", get_output_buffer, 1, 1301 b2tv(false)); 1302 add_applicative(K, ground_env, "get-output-bytevector", get_output_buffer, 1303 1, b2tv(true)); 1304 1305 /* 15.1.7 read */ 1306 add_applicative(K, ground_env, "read", gread, 0); 1307 /* 15.1.8 write */ 1308 add_applicative(K, ground_env, "write", gwrite, 0); 1309 /* 15.1.? write-simple */ 1310 add_applicative(K, ground_env, "write-simple", gwrite_simple, 0); 1311 1312 /* 15.1.? eof-object? */ 1313 add_applicative(K, ground_env, "eof-object?", typep, 2, symbol, 1314 i2tv(K_TEOF)); 1315 /* 15.1.? newline */ 1316 add_applicative(K, ground_env, "newline", newline, 0); 1317 /* 15.1.? display */ 1318 add_applicative(K, ground_env, "display", display, 0); 1319 /* 15.1.? read-line */ 1320 add_applicative(K, ground_env, "read-line", read_line, 0); 1321 /* 15.1.? flush-output-port */ 1322 add_applicative(K, ground_env, "flush-output-port", flush, 0); 1323 1324 /* 15.1.? write-char */ 1325 add_applicative(K, ground_env, "write-char", write_char, 0); 1326 /* 15.1.? read-char */ 1327 add_applicative(K, ground_env, "read-char", read_peek_char, 1, 1328 b2tv(false)); 1329 /* 15.1.? peek-char */ 1330 add_applicative(K, ground_env, "peek-char", read_peek_char, 1, 1331 b2tv(true)); 1332 /* 15.1.? char-ready? */ 1333 /* XXX: this always return #t, proper behaviour requires platform 1334 specific code (probably select for posix, a thread for windows 1335 (at least for files & consoles), I think pipes and sockets may 1336 have something */ 1337 add_applicative(K, ground_env, "char-ready?", char_readyp, 0); 1338 /* 15.1.? write-u8 */ 1339 add_applicative(K, ground_env, "write-u8", write_u8, 0); 1340 /* 15.1.? read-u8 */ 1341 add_applicative(K, ground_env, "read-u8", read_peek_u8, 1, 1342 b2tv(false)); 1343 /* 15.1.? peek-u8 */ 1344 add_applicative(K, ground_env, "peek-u8", read_peek_u8, 1, 1345 b2tv(true)); 1346 /* 15.1.? u8-ready? */ 1347 /* XXX: this always return #t, proper behaviour requires platform 1348 specific code (probably select for posix, a thread for windows 1349 (at least for files & consoles), I think pipes and sockets may 1350 have something */ 1351 add_applicative(K, ground_env, "u8-ready?", u8_readyp, 0); 1352 /* 15.2.1 call-with-input-file, call-with-output-file */ 1353 add_applicative(K, ground_env, "call-with-input-file", call_with_file, 1354 2, symbol, b2tv(false)); 1355 add_applicative(K, ground_env, "call-with-output-file", call_with_file, 1356 2, symbol, b2tv(true)); 1357 /* 15.2.2 load */ 1358 add_applicative(K, ground_env, "load", load, 0); 1359 /* 15.2.? require */ 1360 add_applicative(K, ground_env, "require", require, 0); 1361 /* 15.2.? registered-requirement? */ 1362 add_applicative(K, ground_env, "registered-requirement?", 1363 registered_requirementP, 0); 1364 /* 15.2.? register-requirement! */ 1365 add_applicative(K, ground_env, "register-requirement!", 1366 register_requirementB, 0); 1367 /* 15.2.? unregister-requirement! */ 1368 add_applicative(K, ground_env, "unregister-requirement!", 1369 unregister_requirementB, 0); 1370 /* 15.2.? find-required-filename */ 1371 add_applicative(K, ground_env, "find-required-filename", 1372 find_required_filename, 0); 1373 /* 15.2.3 get-module */ 1374 add_applicative(K, ground_env, "get-module", get_module, 0); 1375 1376 /* 1377 * That's all there is in the report combined with r5rs and r7rs scheme. 1378 * TODO 1379 * It would be good to be able to select between append, truncate and 1380 * error if a file exists, but that would need to be an option in all three 1381 * methods of opening. Also some directory checking, traversing, etc, 1382 * would be nice 1383 */ 1384 } 1385 1386 /* XXX lock? */ 1387 /* init continuation names */ 1388 void kinit_ports_cont_names(klisp_State *K) 1389 { 1390 Table *t = tv2table(G(K)->cont_name_table); 1391 1392 add_cont_name(K, t, do_close_file_ret, "close-file-and-ret"); 1393 }