;;; specialized-io.scm - a collection of functions for super-fast unsafe ;;; token I/O ; ; Copyright (c) 2010-2015, Jeronimo C. Pellegrini ; All rights reserved. ; ; Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following ; conditions are met: ; ; Redistributions of source code must retain the above copyright notice, this list of conditions and the following ; disclaimer. ; Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following ; disclaimer in the documentation and/or other materials provided with the distribution. ; Neither the name of the author nor the names of its contributors may be used to endorse or promote ; products derived from this software without specific prior written permission. ; ; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS ; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY ; AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR ; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR ; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR ; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY ; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR ; OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE ; POSSIBILITY OF SUCH DAMAGE. (module specialized-io * (import scheme chicken foreign srfi-13) (import (only numbers real-part imag-part make-rectangular)) (require-extension srfi-13) (define +specialized-io-string-buffer-size+ 500) ;; Error procedure to be called when a reading procedure fails. ;; This cn probably be enhanced with more arguments etc. (define specialized-io-error error) ;; This is a wrapper over fscanf: (define c-fscanf (foreign-lambda* int ((scheme-object port) (c-string fmt) (c-pointer var)) "C_return (fscanf(C_port_file(port), fmt, var) );")) ;; Wrapper for fprintf; writes a fixnum. (define c-print-fixnum (foreign-lambda* int ((scheme-object port) (int var)) "C_return (fprintf(C_port_file(port), \"%d\", var) );")) ;; Wrapper for fprintf; writes a flonum. (define c-print-flonum (foreign-lambda* int ((scheme-object port) (double var)) "C_return (fprintf(C_port_file(port), \"%lf\", var) );")) ;; Reads a flonum from a port. (define read-flonum (lambda (port) (let-location ((d double)) (let ((x (c-fscanf port "%lf" (location d)))) (if (not (= x 1)) (specialized-io-error "read-flonum: failed!") d))))) ;; Writes a flonum to a port (define write-flonum (lambda (num port) (let ((x (c-print-flonum port num))) (if (< x 0) ;; fprintf returns negative on error (specialized-io-error "write-flonum: failed!"))))) ;; Reads a complex number from a port in R5RS format ("A+Bi") and returns ;; it. (define read-complex (lambda (port) (let ((real (read-flonum port))) (let ((plus (peek-char port))) (cond ((or (char=? plus #\+) (char=? plus #\-)) (let ((imaginary (read-flonum port))) (cond ((char=? #\i (peek-char port)) (read-one-char port) ; consume 'i' (make-rectangular real imaginary)) (else (specialized-io-error "read-complex: failed!"))))) (else real)))))) ;; is this OK? ;; Writes a complex number from a port in R5RS format ("A+Bi"). (define write-complex (lambda (num port) (let (;(real (real-part num)) (imaginary (imag-part num))) (write-flonum (real-part num) port) (cond ((not (zero? imaginary)) (if (> imaginary 0.0) (write-one-char #\+ port)) (write-flonum imaginary port) (write-one-char #\i port)))))) ;; Reads a fixnum from port. (define read-fixnum (lambda (port) (let-location ((d int)) (let ((x (c-fscanf port "%d" (location d)))) (if (not (= x 1)) (specialized-io-error "read-fixnum: failed!") d))))) ;; Writes a fixnum to a port (define write-fixnum (lambda (num port) (let ((x (c-print-fixnum port num))) (if (< x 0) ;; fprintf returns negative on error (specialized-io-error "write-fixnum: failed!"))))) ;; Writes a character to a port. ;; Retrurns 1 on error, or zero on success. (define read-char-aux (foreign-lambda* int ((scheme-object port) (c-pointer var)) "#include \n" "int c = fgetc(C_port_file(port));" "if (c == EOF)" " C_return(1); /* eof/error */" "else {" " *((char*)var) = (char) c;" " C_return(0); /* OK */" "}")) ;; Reads a character from a port. (define read-one-char (lambda (port) (let-location ((c char)) (let ((x (read-char-aux port (location c)))) (if (= x 1) (specialized-io-error "read-one-char: failed!") c))))) ;; Writes a character to a port (define write-one-char (lambda (c port) (if (fx= 1 ((foreign-lambda* int ((char var) (scheme-object port)) "#include \n" "if (fputc (var, C_port_file(port)) == EOF)" " return(1);" "else" " return(0);") c port)) (specialized-io-error "write-one-char: failed!")))) ;; Reads a string from the current position of port until sentinel is ;; found (and sentinel will be the last character of the returned string). (define read-string-until (lambda (sentinel port) (let loop ((the-string (make-string +specialized-io-string-buffer-size+)) (i 0)) (string-set! the-string i (read-one-char port)) (cond ((char=? (string-ref the-string i) sentinel) (substring/shared the-string 0 (fx+ i 1))) ((fx>= (fx+ 1 i) +specialized-io-string-buffer-size+) (loop (string-append/shared the-string (make-string +specialized-io-string-buffer-size+)) (fx+ 1 i))) (else (loop the-string (fx+ 1 i))))))) ;; Reads a string from the current position of port until sentinel is ;; found (and sentinel will be the last character of the returned string). (define read-string-between (lambda (left right port) (let ((new-string (make-string +specialized-io-string-buffer-size+))) ;; finds left character and puts it at position zero of string: (let find-left () (string-set! new-string 0 (read-one-char port)) (if (not (char=? left (string-ref new-string 0))) (find-left))) ;; fill rest of string, until right char is found: (let loop ((the-string new-string) (i 1)) (string-set! the-string i (read-one-char port)) (cond ((char=? (string-ref the-string i) right) ; found it! (substring/shared the-string 0 (fx+ i 1))) ((fx>= (fx+ 1 i) +specialized-io-string-buffer-size+) ; full buffer; double its size! (loop (string-append/shared the-string (make-string +specialized-io-string-buffer-size+)) (fx+ 1 i))) (else ; keep walking! :-) (loop the-string (fx+ 1 i)))))))) ;; Reads a string of at most n bytes from port. (define read-string-n (lambda (n port) (let ((the-string (make-string n))) (do ((i 0 (fx+ 1 i))) ((>= i n) the-string) (string-set! the-string i (read-one-char port)))))) ;; Writes a string to a port, using one single call to fprintf. (define write-one-string (foreign-lambda* void ((c-string str) (scheme-object port)) "#include \n" "fprintf(C_port_file(port), str);")) )