1#!core 2;;; Ypsilon Scheme System 3;;; Copyright (c) 2004-2008 Y.FUJITA, LittleWing Company Limited. 4;;; See license.txt for terms and conditions of use. 5 6(library (core io assistants) 7 8 (export port-type 9 port-direction 10 port-lookup-file-option-code 11 port-lookup-buffer-mode-code 12 port-lookup-codec-code 13 port-lookup-eol-style-code 14 port-lookup-error-handling-mode-code 15 port-reverse-lookup-codec-code 16 port-reverse-lookup-eol-style-code 17 port-reverse-lookup-error-handling-mode-code 18 make-file-options) 19 20 (import (core primitives) (core enums)) 21 22 (define direction-codes 23 '((input . 1) (output . 2) (input/output . 3))) 24 25 (define type-codes 26 '((file . 1) (bytevector . 2) (custom . 3))) 27 28 (define file-option-codes 29 '((no-create . 1) (no-fail . 2) (no-truncate . 4))) 30 31 (define buffer-mode-codes 32 '((none . 1) (line . 2) (block . 3))) 33 34 (define codec-codes 35 '((latin-1 . 1) (utf-8 . 2) (utf-16 . 3))) 36 37 (define eol-style-codes 38 '((none . 1) (lf . 2) (cr . 3) (crlf . 4) (nel . 5) (crnel . 6) (ls . 7))) 39 40 (define error-handling-mode-codes 41 '((ignore . 1) (raise . 2) (replace . 3))) 42 43 (define flip (lambda (lst) (map (lambda (e) (cons (cdr e) (car e))) lst))) 44 45 (define flipped-codec-codes (flip codec-codes)) 46 47 (define flipped-eol-style-codes (flip eol-style-codes)) 48 49 (define flipped-error-handling-mode-codes (flip error-handling-mode-codes)) 50 51 (define lookup (lambda (obj alist) (cond ((assq obj alist) => cdr) (else #f)))) 52 53 (define-syntax port-type 54 (lambda (x) 55 (syntax-case x () 56 ((_ type) 57 (datum->syntax 58 #'k 59 (cond ((assq (syntax->datum (syntax type)) type-codes) => cdr) 60 (else 61 (syntax-violation 'port-type "invalid port type" x))))) 62 (_ 63 (syntax-violation 'port-type "invalid port type" x))))) 64 65 (define-syntax port-direction 66 (lambda (x) 67 (syntax-case x (input output) 68 ((_ input) 69 (datum->syntax #'k (lookup 'input direction-codes))) 70 ((_ output) 71 (datum->syntax #'k (lookup 'output direction-codes))) 72 ((_ input output) 73 (datum->syntax #'k (lookup 'input/output direction-codes))) 74 (_ 75 (syntax-violation 'port-direction "invalid port direction" x))))) 76 77 (define port-lookup-file-option-code (lambda (obj) (lookup obj file-option-codes))) 78 (define port-lookup-buffer-mode-code (lambda (obj) (lookup obj buffer-mode-codes))) 79 (define port-lookup-codec-code (lambda (obj) (lookup obj codec-codes))) 80 (define port-lookup-eol-style-code (lambda (obj) (lookup obj eol-style-codes))) 81 (define port-lookup-error-handling-mode-code (lambda (obj) (lookup obj error-handling-mode-codes))) 82 (define port-reverse-lookup-codec-code (lambda (obj) (lookup obj flipped-codec-codes))) 83 (define port-reverse-lookup-eol-style-code (lambda (obj) (lookup obj flipped-eol-style-codes))) 84 (define port-reverse-lookup-error-handling-mode-code (lambda (obj) (lookup obj flipped-error-handling-mode-codes))) 85 86 (define make-file-options (enum-set-constructor (make-enumeration (map car file-option-codes)))) 87 88 ) 89 90(library (core io) 91 92 (export file-options 93 buffer-mode 94 buffer-mode? 95 utf-8-codec 96 utf-16-codec 97 latin-1-codec 98 eol-style 99 error-handling-mode 100 make-transcoder 101 transcoder-codec 102 transcoder-eol-style 103 transcoder-error-handling-mode 104 native-transcoder 105 native-eol-style 106 bytevector->string 107 string->bytevector 108 eof-object 109 eof-object? 110 port? 111 port-transcoder 112 textual-port? 113 binary-port? 114 transcoded-port 115 port-has-port-position? 116 port-position 117 port-has-set-port-position!? 118 set-port-position! 119 120 close-port 121 call-with-port 122 input-port? 123 port-eof? 124 125 open-file-input-port 126 open-bytevector-input-port 127 open-string-input-port 128 standard-input-port 129 current-input-port 130 131 get-u8 132 lookahead-u8 133 get-bytevector-n 134 get-bytevector-n! 135 get-bytevector-some 136 get-bytevector-all 137 138 get-char 139 lookahead-char 140 get-string-n 141 get-string-n! 142 get-string-all 143 get-line 144 get-datum 145 146 output-port? 147 flush-output-port 148 output-port-buffer-mode 149 open-file-output-port 150 open-bytevector-output-port 151 call-with-bytevector-output-port 152 open-string-output-port 153 call-with-string-output-port 154 standard-output-port 155 standard-error-port 156 current-output-port 157 current-error-port 158 159 put-u8 160 put-bytevector 161 put-char 162 put-string 163 put-datum 164 165 open-file-input/output-port 166 167 ; io simple 168 call-with-input-file 169 call-with-output-file 170 with-input-from-file 171 with-output-to-file 172 open-input-file 173 open-output-file 174 close-input-port 175 close-output-port 176 read-char 177 peek-char 178 read 179 write-char 180 newline 181 display 182 write 183 184 make-custom-binary-input-port 185 make-custom-textual-input-port 186 make-custom-binary-output-port 187 make-custom-textual-output-port 188 make-custom-binary-input/output-port 189 make-custom-textual-input/output-port 190 191 &i/o make-i/o-error i/o-error? 192 &i/o-read make-i/o-read-error i/o-read-error? 193 &i/o-write make-i/o-write-error i/o-write-error? 194 &i/o-invalid-position make-i/o-invalid-position-error i/o-invalid-position-error? i/o-error-position 195 &i/o-filename make-i/o-filename-error i/o-filename-error? i/o-error-filename 196 &i/o-file-protection make-i/o-file-protection-error i/o-file-protection-error? 197 &i/o-file-is-read-only make-i/o-file-is-read-only-error i/o-file-is-read-only-error? 198 &i/o-file-already-exists make-i/o-file-already-exists-error i/o-file-already-exists-error? 199 &i/o-file-does-not-exist make-i/o-file-does-not-exist-error i/o-file-does-not-exist-error? 200 &i/o-port make-i/o-port-error i/o-port-error? i/o-error-port 201 202 &i/o-decoding make-i/o-decoding-error i/o-decoding-error? 203 &i/o-encoding make-i/o-encoding-error i/o-encoding-error? i/o-encoding-error-char 204 205 open-temporary-file-port 206 format) 207 208 (import (core io assistants) 209 (core primitives) 210 (core syntax-case) 211 (core lists) 212 (core conditions) 213 (core bytevectors) 214 (core optargs) 215 (core chkarg) 216 (core enums)) 217 218 ;; 8.2.2 File options 219 220 (define-syntax file-options 221 (lambda (x) 222 (syntax-case x () 223 ((_ options ...) 224 (let ((lst (syntax->datum (syntax (options ...))))) 225 (or (and (list-of-unique-symbols? lst) (for-all port-lookup-file-option-code lst)) 226 (syntax-violation 'file-options "invalid option" x)) 227 (syntax (make-file-options '(options ...))))) 228 (_ 229 (syntax-violation 'file-options "invalid syntax" x))))) 230 231 (define file-options->bits 232 (lambda (x) 233 (apply + (map (lambda (e) (port-lookup-file-option-code e)) (enum-set->list x))))) 234 235 ;; 8.2.3 Buffer modes 236 237 (define-syntax buffer-mode 238 (lambda (x) 239 (syntax-case x () 240 ((_ mode) 241 (or (port-lookup-buffer-mode-code (syntax->datum (syntax mode))) 242 (syntax-violation 'buffer-mode "invalid buffer mode" x)) 243 (syntax 'mode)) 244 (_ 245 (syntax-violation 'buffer-mode "invalid buffer mode" x))))) 246 247 (define buffer-mode? 248 (lambda (mode) 249 (and (port-lookup-buffer-mode-code mode) #t))) 250 251 ;; 8.2.4 Transcoders 252 253 (define predefined-utf-8-codec (tuple 'type:codec 'utf-8)) 254 (define predefined-utf-16-codec (tuple 'type:codec 'utf-16)) 255 (define predefined-latin-1-codec (tuple 'type:codec 'latin-1)) 256 257 (define utf-8-codec (lambda () predefined-utf-8-codec)) 258 (define utf-16-codec (lambda () predefined-utf-16-codec)) 259 (define latin-1-codec (lambda () predefined-latin-1-codec)) 260 261 (define-syntax eol-style 262 (lambda (x) 263 (syntax-case x () 264 ((_ style) 265 (or (port-lookup-eol-style-code (syntax->datum (syntax style))) 266 (syntax-violation 'eol-style "invalid eol style" x)) 267 (syntax 'style)) 268 (_ 269 (syntax-violation 'eol-style "invalid eol style" x))))) 270 271 (define-syntax error-handling-mode 272 (lambda (x) 273 (syntax-case x () 274 ((_ mode) 275 (or (port-lookup-error-handling-mode-code (syntax->datum (syntax mode))) 276 (syntax-violation 'error-handling-mode "invalid directive" x)) 277 (syntax 'mode)) 278 (_ 279 (syntax-violation 'error-handling-mode "invalid directive" x))))) 280 281 (define make-transcoder 282 (lambda (codec . options) 283 (let-optionals options ((eol-style (native-eol-style)) (error-handling-mode 'replace)) 284 (let ((bv (make-bytevector 3))) 285 (bytevector-u8-set! bv 0 (port-lookup-codec-code (tuple-ref codec 1))) 286 (bytevector-u8-set! bv 1 (port-lookup-eol-style-code eol-style)) 287 (bytevector-u8-set! bv 2 (port-lookup-error-handling-mode-code error-handling-mode)) 288 (tuple 'type:transcoder bv))))) 289 290 (define transcoder-descriptor 291 (lambda (transcoder) 292 (tuple-ref transcoder 1))) 293 294 (define transcoder-codec 295 (lambda (transcoder) 296 (case (port-reverse-lookup-codec-code (bytevector-u8-ref (transcoder-descriptor transcoder) 0)) 297 ((latin-1) (latin-1-codec)) 298 ((utf-8) (utf-8-codec)) 299 ((utf-16) (utf-16-codec))))) 300 301 (define transcoder-eol-style 302 (lambda (transcoder) 303 (port-reverse-lookup-eol-style-code (bytevector-u8-ref (transcoder-descriptor transcoder) 1)))) 304 305 (define transcoder-error-handling-mode 306 (lambda (transcoder) 307 (port-reverse-lookup-error-handling-mode-code (bytevector-u8-ref (transcoder-descriptor transcoder) 2)))) 308 309 (define native-transcoder 310 (let ((transcoder (tuple 'type:transcoder (native-transcoder-descriptor)))) 311 (lambda () transcoder))) 312 313 (define native-eol-style (lambda () (transcoder-eol-style (native-transcoder)))) 314 315 (define bytevector->string 316 (lambda (bytes transcoder) 317 (let-values (((out extract) (open-string-output-port))) 318 (call-with-port 319 (open-bytevector-input-port bytes transcoder) 320 (lambda (in) 321 (let loop ((c (get-char in))) 322 (cond ((eof-object? c) (extract)) 323 (else 324 (put-char out c) 325 (loop (get-char in)))))))))) 326 327 #; (define string->bytevector 328 (lambda (string transcoder) 329 (let-values (((out extract) (open-bytevector-output-port transcoder))) 330 (call-with-port 331 (open-string-input-port string) 332 (lambda (in) 333 (let loop ((c (get-char in))) 334 (cond ((eof-object? c) (extract)) 335 (else 336 (put-char out c) 337 (loop (get-char in)))))))))) 338 339 (define string->bytevector 340 (lambda (string transcoder) 341 (let-values (((out extract) (open-bytevector-output-port transcoder))) 342 (call-with-port 343 (make-string-input-port string) 344 (lambda (in) 345 (let loop ((c (get-char in))) 346 (cond ((eof-object? c) (extract)) 347 (else 348 (put-char out c) 349 (loop (get-char in)))))))))) 350 351 ;; 8.2.6 Input and output ports 352 353 (define port-transcoder 354 (lambda (port) 355 (let ((desc (port-transcoder-descriptor port))) 356 (and desc 357 (if (eq? desc #t) 358 (native-transcoder) 359 (tuple 'type:transcoder desc)))))) 360 361 (define textual-port? 362 (lambda (port) 363 (and (port-transcoder-descriptor port) #t))) 364 365 (define binary-port? 366 (lambda (port) 367 (not (port-transcoder-descriptor port)))) 368 369 (define transcoded-port 370 (lambda (port transcoder) 371 (make-transcoded-port port (transcoder-descriptor transcoder)))) 372 373 ;; 8.2.7 Input ports 374 375 (define open-file-input-port 376 (lambda (filename . options) 377 (let-optionals options 378 ((file-options (file-options)) 379 (buffer-mode 'block) 380 (transcoder #f)) 381 (open-port (port-type file) 382 (port-direction input) 383 filename 384 (file-options->bits file-options) 385 (port-lookup-buffer-mode-code buffer-mode) 386 (and transcoder (transcoder-descriptor transcoder)))))) 387 388 (define open-bytevector-input-port 389 (lambda (bytes . options) 390 (let-optionals options ((transcoder #f)) 391 (open-port (port-type bytevector) 392 (port-direction input) 393 'bytevector 394 bytes 395 #f 396 (and transcoder (transcoder-descriptor transcoder)))))) 397 398 (define open-string-input-port 399 (lambda (string) 400 (make-string-input-port string))) 401 402 (define make-custom-binary-input-port 403 (lambda (id read! get-position set-position! close) 404 (open-port (port-type custom) 405 (port-direction input) 406 id 407 (vector #f read! #f get-position set-position! close) 408 #f 409 #f))) 410 411 (define make-custom-textual-input-port 412 (lambda (id read! get-position set-position! close) 413 (define port) 414 415 (define ht-token (make-core-hashtable 'eqv?)) 416 417 (define bv-read! 418 (lambda (bv start count) 419 (cond ((= count 0) 0) 420 (else 421 (let* ((len (div count 4)) 422 (str (make-string len #\nul)) 423 (count (read! str 0 len))) 424 (cond ((= count 0) 0) 425 (else 426 (let* ((bv-utf8 (string->utf8 (substring str 0 count))) 427 (count (bytevector-length bv-utf8))) 428 (bytevector-copy! bv-utf8 0 bv start count) 429 count)))))))) 430 431 (define bv-get-position 432 (lambda (token) 433 (core-hashtable-set! ht-token token (get-position)) 434 token)) 435 436 (define bv-set-position! 437 (lambda (token) 438 (cond ((core-hashtable-ref ht-token token #f) 439 => (lambda (pos) (set-position! pos))) 440 ((warning-level) 441 (format (current-error-port) "~&warning in set-port-position: expected return value of a call to get-position, but got ~u~%~!" token) 442 (set-position! token)) 443 (else 444 (set-position! token))))) 445 446 (set! port (open-port (port-type custom) 447 (port-direction input) 448 id 449 (vector #t (and read! bv-read!) #f (and get-position bv-get-position) (and set-position! bv-set-position!) close) 450 #f 451 #t)) 452 port)) 453 454 ;; 8.2.10 Output ports 455 456 (define open-file-output-port 457 (lambda (filename . options) 458 (let-optionals options 459 ((file-options (file-options)) 460 (buffer-mode 'block) 461 (transcoder #f)) 462 (open-port (port-type file) 463 (port-direction output) 464 filename 465 (file-options->bits file-options) 466 (port-lookup-buffer-mode-code buffer-mode) 467 (and transcoder (transcoder-descriptor transcoder)))))) 468 469 (define bytevector-output-port-values 470 (lambda (port) 471 (values port (lambda () (extract-accumulated-bytevector port))))) 472 473 (define open-bytevector-output-port 474 (lambda options 475 (let-optionals options ((transcoder #f)) 476 (bytevector-output-port-values 477 (open-port (port-type bytevector) 478 (port-direction output) 479 'bytevector 480 #f 481 #f 482 (and transcoder (transcoder-descriptor transcoder))))))) 483 484 (define call-with-bytevector-output-port 485 (lambda (proc . options) 486 (let-optionals options ((transcoder #f)) 487 (let-values (((port extractor) (open-bytevector-output-port transcoder))) 488 (dynamic-wind 489 (lambda () #f) 490 (lambda () (proc port) (extractor)) 491 (lambda () (close-port port))))))) 492 493 (define call-with-string-output-port 494 (lambda (proc) 495 (let-values (((port extractor) (open-string-output-port))) 496 (dynamic-wind 497 (lambda () #f) 498 (lambda () (proc port) (extractor)) 499 (lambda () (close-port port)))))) 500 501 (define string-output-port-values 502 (lambda (port) 503 (values port (lambda () (extract-accumulated-string port))))) 504 505 (define open-string-output-port 506 (lambda () 507 (string-output-port-values (make-string-output-port)))) 508 509 (define make-custom-binary-output-port 510 (lambda (id write! get-position set-position! close) 511 (open-port (port-type custom) 512 (port-direction output) 513 id 514 (vector #f #f write! get-position set-position! close) 515 #f 516 #f))) 517 518 (define make-custom-textual-output-port 519 (lambda (id write! get-position set-position! close) 520 521 (define port) 522 523 (define ht-token (make-core-hashtable 'eqv?)) 524 525 (define bv-write! 526 (lambda (bv start count) 527 (cond ((= count 0) (write! "" 0 0) 0) 528 (else 529 (let ((bv-utf8 (make-bytevector count))) 530 (bytevector-copy! bv start bv-utf8 0 count) 531 (let* ((str (utf8->string bv-utf8)) 532 (len (string-length str))) 533 (let ((written (write! str 0 len))) 534 (bytevector-length (string->utf8 (substring str 0 written)))))))))) 535 536 (define bv-get-position 537 (lambda (token) 538 (core-hashtable-set! ht-token token (get-position)) 539 token)) 540 541 (define bv-set-position! 542 (lambda (token) 543 (cond ((core-hashtable-ref ht-token token #f) 544 => (lambda (pos) (set-position! pos))) 545 ((warning-level) 546 (format (current-error-port) "~&warning in set-port-position: expected return value of a call to get-position, but got ~u~%~!" token) 547 (set-position! token)) 548 (else 549 (set-position! token))))) 550 551 (set! port (open-port (port-type custom) 552 (port-direction output) 553 id 554 (vector #t #f (and write! bv-write!) (and get-position bv-get-position) (and set-position! bv-set-position!) close) 555 #f 556 #t)) 557 port)) 558 559 ;; 8.2.13 Input/output ports 560 561 (define open-file-input/output-port 562 (lambda (filename . options) 563 (let-optionals options 564 ((file-options (file-options)) 565 (buffer-mode 'block) 566 (transcoder #f)) 567 (open-port (port-type file) 568 (port-direction input output) 569 filename 570 (file-options->bits file-options) 571 (port-lookup-buffer-mode-code buffer-mode) 572 (and transcoder (transcoder-descriptor transcoder)))))) 573 574 (define make-custom-binary-input/output-port 575 (lambda (id read! write! get-position set-position! close) 576 (open-port (port-type custom) 577 (port-direction input output) 578 id 579 (vector #f read! write! get-position set-position! close) 580 #f 581 #f))) 582 583 (define make-custom-textual-input/output-port 584 (lambda (id read! write! get-position set-position! close) 585 586 (define port) 587 588 (define ht-token (make-core-hashtable 'eqv?)) 589 590 (define bv-read! 591 (lambda (bv start count) 592 (cond ((= count 0) 0) 593 (else 594 (let* ((len (div count 4)) 595 (str (make-string len #\nul)) 596 (count (read! str 0 len))) 597 (cond ((= count 0) 0) 598 (else 599 (let* ((bv-utf8 (string->utf8 (substring str 0 count))) 600 (count (bytevector-length bv-utf8))) 601 (bytevector-copy! bv-utf8 0 bv start count) 602 count)))))))) 603 604 (define bv-write! 605 (lambda (bv start count) 606 (cond ((= count 0) (write! "" 0 0) 0) 607 (else 608 (let ((bv-utf8 (make-bytevector count))) 609 (bytevector-copy! bv start bv-utf8 0 count) 610 (let* ((str (utf8->string bv-utf8)) 611 (len (string-length str))) 612 (let ((written (write! str 0 len))) 613 (bytevector-length (string->utf8 (substring str 0 written)))))))))) 614 615 (define bv-get-position 616 (lambda (token) 617 (core-hashtable-set! ht-token token (get-position)) 618 token)) 619 620 (define bv-set-position! 621 (lambda (token) 622 (cond ((core-hashtable-ref ht-token token #f) 623 => (lambda (pos) (set-position! pos))) 624 ((warning-level) 625 (format (current-error-port) "~&warning in set-port-position: expected return value of a call to get-position, but got ~u~%~!" token) 626 (set-position! token)) 627 (else 628 (set-position! token))))) 629 630 (set! port (open-port (port-type custom) 631 (port-direction input output) 632 id 633 (vector #t (and read! bv-read!) (and write! bv-write!) (and get-position bv-get-position) (and set-position! bv-set-position!) close) 634 #f 635 #t)) 636 port)) 637 638 ;; 8.3 Simple I/O 639 640 (define call-with-input-file 641 (lambda (filename proc) 642 (call-with-port (open-input-file filename) proc))) 643 644 (define call-with-output-file 645 (lambda (filename proc) 646 (call-with-port (open-output-file filename) proc))) 647 648 (define with-input-from-file 649 (lambda (filename thunk) 650 (let ((port (open-input-file filename)) (save (current-input-port))) 651 (dynamic-wind 652 (lambda () (set-current-input-port! port)) 653 (lambda () (let ((ans (thunk))) (close-input-port port) ans)) 654 (lambda () (set-current-input-port! save)))))) 655 656 (define with-output-to-file 657 (lambda (filename thunk) 658 (let ((port (open-output-file filename)) (save (current-output-port))) 659 (dynamic-wind 660 (lambda () (set-current-output-port! port)) 661 (lambda () (let ((ans (thunk))) (close-output-port port) ans)) 662 (lambda () (set-current-output-port! save)))))) 663 664 (define open-input-file 665 (lambda (filename) 666 (open-file-input-port filename (file-options) (buffer-mode block) (native-transcoder)))) 667 668 (define open-output-file 669 (lambda (filename) 670 (open-file-output-port filename (file-options) (buffer-mode block) (native-transcoder)))) 671 672 (define close-input-port 673 (lambda (port) 674 (close-port port))) 675 676 (define close-output-port 677 (lambda (port) 678 (close-port port))) 679 680 ;; extension 681 682 (define open-temporary-file-port 683 (lambda options 684 (let-optionals options ((name "temporary file") (transcoder #f)) 685 (make-temporary-file-port name (and transcoder (transcoder-descriptor transcoder)))))) 686 687 ) ;[end] 688