ikarus/scheme/ikarus.io.ss

;;; Ikarus Scheme -- A compiler for R6RS Scheme.
;;; Copyright (C) 2006,2007,2008  Abdulaziz Ghuloum
;;; 
;;; This program is free software: you can redistribute it and/or modify
;;; it under the terms of the GNU General Public License version 3 as
;;; published by the Free Software Foundation.
;;; 
;;; This program is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;;; General Public License for more details.
;;; 
;;; You should have received a copy of the GNU General Public License
;;; along with this program.  If not, see <http://www.gnu.org/licenses/>.


(library (ikarus.io) 
  
  (export 
    port? input-port? output-port? textual-port? binary-port?
    open-file-input-port open-input-file 
    call-with-input-file with-input-from-file
    standard-input-port current-input-port
    open-bytevector-input-port
    open-string-input-port open-string-input-port/id
    with-input-from-string
    make-custom-binary-input-port 
    make-custom-binary-output-port 
    make-custom-textual-input-port 
    make-custom-textual-output-port 
    transcoded-port port-transcoder
    close-port port-closed? close-input-port close-output-port
    port-eof?
    get-char lookahead-char read-char peek-char
    get-string-n get-string-n! get-string-all get-line read-line
    get-u8 lookahead-u8 
    get-bytevector-n get-bytevector-n!
    get-bytevector-some get-bytevector-all 
    port-position port-has-port-position? 
    set-port-position! port-has-set-port-position!? 
    call-with-port
    flush-output-port 
    put-u8 put-bytevector
    put-char write-char
    put-string
    open-bytevector-output-port
    call-with-bytevector-output-port
    open-string-output-port with-output-to-string
    with-output-to-port
    call-with-string-output-port 
    open-output-string get-output-string
    standard-output-port standard-error-port
    current-output-port current-error-port
    open-file-output-port open-output-file 
    call-with-output-file with-output-to-file
    console-output-port
    console-error-port
    console-input-port
    newline
    port-mode set-port-mode!
    output-port-buffer-mode
    reset-input-port!
    reset-output-port!
    port-id
    input-port-byte-position
    process process-nonblocking
    
    tcp-connect tcp-connect-nonblocking
    udp-connect udp-connect-nonblocking
    tcp-server-socket tcp-server-socket-nonblocking
    accept-connection accept-connection-nonblocking
    close-tcp-server-socket 
    register-callback
    input-socket-buffer-size output-socket-buffer-size)


  
  (import 
    (ikarus system $io)
    (except (ikarus)
      port? input-port? output-port? textual-port? binary-port? 
      open-file-input-port open-input-file 
      call-with-input-file with-input-from-file
      standard-input-port current-input-port
      open-bytevector-input-port
      open-string-input-port with-input-from-string
      make-custom-binary-input-port
      make-custom-binary-output-port 
      make-custom-textual-input-port 
      make-custom-textual-output-port 
      transcoded-port port-transcoder
      close-port port-closed? close-input-port close-output-port
      port-eof?
      get-char lookahead-char read-char peek-char
      get-string-n get-string-n! get-string-all get-line read-line
      get-u8 lookahead-u8 
      get-bytevector-n get-bytevector-n!
      get-bytevector-some get-bytevector-all 
      port-position port-has-port-position? 
      set-port-position! port-has-set-port-position!? 
      call-with-port
      flush-output-port
      put-u8 put-bytevector
      put-char write-char
      put-string
      open-bytevector-output-port
      call-with-bytevector-output-port
      open-string-output-port with-output-to-string
      call-with-string-output-port
      open-output-string get-output-string
      standard-output-port standard-error-port
      current-output-port current-error-port
      open-file-output-port open-output-file 
      call-with-output-file with-output-to-file
      with-output-to-port
      console-output-port
      console-input-port
      console-error-port
      newline
      port-mode set-port-mode!
      output-port-buffer-mode
      reset-input-port!
      reset-output-port!
      port-id
      process process-nonblocking
      tcp-connect tcp-connect-nonblocking
      udp-connect udp-connect-nonblocking
      tcp-server-socket tcp-server-socket-nonblocking
      accept-connection accept-connection-nonblocking
      close-tcp-server-socket 
      register-callback
      input-socket-buffer-size output-socket-buffer-size
      ))

  ;(define-syntax assert* (identifier-syntax assert))
  (define-syntax assert* (syntax-rules () [(_ . x) (void)]))

  (module UNSAFE  
    (fx< fx<= fx> fx>= fx= fx+ fx-
     fxior fxand fxsra fxsll
     integer->char char->integer
     string-ref string-set! string-length
     bytevector-u8-ref bytevector-u8-set!
     bytevector-u16-ref)
    (import 
      (rename (ikarus system $strings)
        ($string-length string-length)
        ($string-ref    string-ref)
        ($string-set!   string-set!))
      (rename (ikarus system $chars)
        ($char->fixnum char->integer)
        ($fixnum->char integer->char))
      (rename (ikarus system $bytevectors)
        ($bytevector-set!   bytevector-u8-set!)
        ($bytevector-u8-ref bytevector-u8-ref))
      (rename (ikarus system $fx) 
        ($fxsra    fxsra)
        ($fxsll    fxsll)
        ($fxlogor  fxior)
        ($fxlogand fxand)
        ($fx+      fx+)
        ($fx-      fx-)
        ($fx<      fx<)
        ($fx>      fx>)
        ($fx>=     fx>=)
        ($fx<=     fx<=)
        ($fx=      fx=)))
    (define (bytevector-u16-ref x i endianness)
      (case endianness
        [(little) 
         (fxlogor (bytevector-u8-ref x i)
                  (fxsll (bytevector-u8-ref x (fx+ i 1)) 8))]
        [else
         (fxlogor (bytevector-u8-ref x (fx+ i 1))
                  (fxsll (bytevector-u8-ref x i) 8))])))


  (define (port? x)
    (import (only (ikarus) port?))
    (port? x))

  (define-syntax define-rrr
    (syntax-rules ()
      [(_ name)
       (define (name . args) 
         (apply die 'name "not implemented" args))]))
 
  (define-syntax u8?
    (let ()
      (import (ikarus system $fx))
      (syntax-rules ()
        [(_ x) 
         ($fxzero? ($fxlogand x -256))])))

  ;(define (u8? x) (and (fixnum? x) (fx>= x 0) (fx< x 256)))
  
  (define (textual-port? x) 
    (fx= (fxand ($port-tag x) textual-port-tag) textual-port-tag))

  (define (binary-port? x) 
    (fx= (fxand ($port-tag x) binary-port-tag) binary-port-tag))

  (define (output-port? x) 
    (fx= (fxand ($port-tag x) output-port-tag) output-port-tag))

  (define (input-port? x)
    (fx= (fxand ($port-tag x) input-port-tag) input-port-tag))

  ;;; everything above this line will turn into primitive
  ;;; ----------------------------------------------------------
  
  (define input-port-tag           #b00000000000001)
  (define output-port-tag          #b00000000000010)
  (define textual-port-tag         #b00000000000100)
  (define binary-port-tag          #b00000000001000)
  (define fast-char-text-tag       #b00000000010000)
  (define fast-u7-text-tag         #b00000000100000)
  (define fast-u8-text-tag         #b00000001100000)
  (define fast-u16be-text-tag      #b00000010000000)
  (define fast-u16le-text-tag      #b00000100000000)
  (define init-u16-text-tag        #b00000110000000)
  (define r6rs-mode-tag            #b01000000000000)
  (define closed-port-tag          #b10000000000000)

  (define port-type-mask           #b00000000001111)
  (define binary-input-port-bits   #b00000000001001)
  (define binary-output-port-bits  #b00000000001010)
  (define textual-input-port-bits  #b00000000000101)
  (define textual-output-port-bits #b00000000000110)

  (define fast-get-byte-tag        #b00000000001001)
  (define fast-get-char-tag        #b00000000010101)
  (define fast-get-utf8-tag        #b00000000100101)
  (define fast-get-latin-tag       #b00000001100101)
  (define fast-get-utf16be-tag     #b00000010000101)
  (define fast-get-utf16le-tag     #b00000100000101)

  (define fast-put-byte-tag        #b00000000001010)
  (define fast-put-char-tag        #b00000000010110)
  (define fast-put-utf8-tag        #b00000000100110)
  (define fast-put-latin-tag       #b00000001100110)
  (define fast-put-utf16be-tag     #b00000010000110)
  (define fast-put-utf16le-tag     #b00000100000110)
  (define init-put-utf16-tag       #b00000110000110)

  (define fast-attrs-mask          #b111111111111)
  (define-syntax $port-fast-attrs
    (identifier-syntax
      (lambda (x) 
        (import (ikarus system $fx))
        ($fxlogand ($port-tag x) fast-attrs-mask))))

  (define (port-id p)
    (if (port? p) 
        ($port-id p)
        (die 'port-id "not a port" p)))

  (define (input-port-byte-position p)
    (if (input-port? p) 
        (let ([pos-vec ($port-position p)])
           (+ (vector-ref pos-vec 0) (fx+ ($port-index p) 1)))
        (error 'input-port-byte-position "not an input port" p)))

  (define (port-position p)
    (define who 'port-position)
    (if (port? p)
        (let ([pos-vec      ($port-position p)]
              [index        ($port-index p)]
              [get-position ($port-get-position p)])
          (cond
            [(procedure? get-position) 
             (let ([pos (get-position)])
               (if (or (fixnum? pos) (bignum? pos))
                   (if (input-port? p)
                       (- pos (- ($port-size p) index))
                       (+ pos index))
                   (die who "invalid returned value from get-position" p)))]
            [(eqv? get-position #t)
             (+ (vector-ref pos-vec 0) index)]
            [else 
             (die who "port does not support port-position operation" p)]))
        (die who "not a port" p)))


  (define (set-port-position! p pos)
    (define who 'set-port-position!)
    (define (set-position! p pos flush?)
      (let ([setpos! ($port-set-position! p)])
        (cond
          [(procedure? setpos!)
           (when flush? (flush-output-port p))
           (setpos! pos)
           ($set-port-index! p 0)
           ($set-port-size! p 0)
           (let ([pos-vec ($port-position p)])
             (vector-set! pos-vec 0 pos))]
          [(eqv? setpos! #t)
           (if (<= pos ($port-size p))
               ($set-port-index! p pos)
               (die who "position out of range" pos))]
          [else
           (die who "port does not support port position" p)])))
    (unless (and (or (fixnum? pos) (bignum? pos)) (>= pos 0))
      (die who "position must be a nonnegative exact integer" pos))
    (cond
      [(output-port? p) (set-position! p pos #t)]
      [(input-port? p)  (set-position! p pos #f)]
      [else (die who "not a port" p)]))


  (define (port-has-port-position? p)
    (define who 'port-has-port-position?)
    (if (port? p)
        (and ($port-get-position p) #t)
        (die who "not a port" p)))

  (define (port-has-set-port-position!? p)
    (define who 'port-has-set-port-position!?)
    (if (port? p)
        (and ($port-set-position! p) #t)
        (die who "not a port" p)))

   
  (define guarded-port
    (let ([G (make-guardian)])
      (define (clean-up)
        (cond
          [(G) =>
           (lambda (p)
             (close-port p)
             (clean-up))]))
      (lambda (p)
        (clean-up)
        (when (fixnum? ($port-cookie p))
          (G p))
        p)))

  (define ($make-custom-binary-port attrs init-size id 
            read! write! get-position set-position! close buffer-size)
    (let ([bv (make-bytevector buffer-size)])
      ($make-port attrs 0 init-size bv #f id read! write! 
                  get-position set-position! close #f (vector 0))))

  (define ($make-custom-textual-port attrs init-size id 
            read! write! get-position set-position! close buffer-size)
    (let ([bv (make-string buffer-size)])
      ($make-port attrs 0 init-size bv #t id read! write! 
                  get-position set-position! close #f (vector 0))))

  (define (make-custom-binary-input-port id 
            read! get-position set-position! close)
    ;;; FIXME: get-position and set-position! are ignored for now
    (define who 'make-custom-binary-input-port)
    (unless (string? id)
      (die who "id is not a string" id))
    (unless (procedure? read!)
      (die who "read! is not a procedure" read!))
    (unless (or (procedure? close) (not close))
      (die who "close should be either a procedure or #f" close))
    (unless (or (procedure? get-position) 
                (not get-position))
      (die who "get-position is not a procedure or #f" 
           get-position))
    ($make-custom-binary-port 
      binary-input-port-bits
      0
      id read! #f 
      get-position
      set-position! 
      close 256))

  (define (make-custom-binary-output-port id 
            write! get-position set-position! close)
    ;;; FIXME: get-position and set-position! are ignored for now
    (define who 'make-custom-binary-output-port)
    (unless (string? id)
      (die who "id is not a string" id))
    (unless (procedure? write!)
      (die who "write! is not a procedure" write!))
    (unless (or (procedure? close) (not close))
      (die who "close should be either a procedure or #f" close))
    (unless (or (procedure? get-position) 
                (not get-position))
      (die who "get-position is not a procedure or #f" 
           get-position)) 
    ($make-custom-binary-port 
      binary-output-port-bits
      256
      id #f write! 
      get-position
      set-position! 
      close 256))

  (define (make-custom-textual-input-port id 
            read! get-position set-position! close)
    ;;; FIXME: get-position and set-position! are ignored for now
    (define who 'make-custom-textual-input-port)
    (unless (string? id)
      (die who "id is not a string" id))
    (unless (procedure? read!)
      (die who "read! is not a procedure" read!))
    (unless (or (procedure? close) (not close))
      (die who "close should be either a procedure or #f" close))
    (unless (or (procedure? get-position)
                (not get-position))
      (die who "get-position is not a procedure or #f" 
           get-position))
    ($make-custom-textual-port 
      (fxior textual-input-port-bits fast-char-text-tag)
      0
      id read! #f get-position
      set-position! close 256))

  (define (make-custom-textual-output-port id 
            write! get-position set-position! close)
    ;;; FIXME: get-position and set-position! are ignored for now
    (define who 'make-custom-textual-output-port)
    (unless (string? id)
      (die who "id is not a string" id))
    (unless (procedure? write!)
      (die who "write! is not a procedure" write!))
    (unless (or (procedure? close) (not close))
      (die who "close should be either a procedure or #f" close))
    (unless (or (procedure? get-position)
                (not get-position))
      (die who "get-position is not a procedure or #f" 
           get-position))
    ($make-custom-textual-port 
      (fxior textual-output-port-bits fast-char-text-tag)
      256
      id #f write! get-position
      set-position! close 256))



  (define (input-transcoder-attrs x who)
    (cond
      [(not x) ;;; binary input port
       binary-input-port-bits]
      [(not (eq? 'none (transcoder-eol-style x)))
       (die who "unsupported transcoder eol-style" 
            (transcoder-eol-style x))]
      [(eq? 'latin-1-codec (transcoder-codec x))
       (fxior textual-input-port-bits fast-u8-text-tag)]
      ;;; attrs for utf-8-codec are set as part of the 
      ;;; bom-reading dance when the first char is read.
      [else textual-input-port-bits]))

  (define (output-transcoder-attrs x who)
    (cond
      [(not x) ;;; binary input port
       binary-output-port-bits]
      [(not (eq? 'none (transcoder-eol-style x)))
       (die who "unsupported transcoder eol-style" 
            (transcoder-eol-style x))]
      [(eq? 'latin-1-codec (transcoder-codec x))
       (fxior textual-output-port-bits fast-u8-text-tag)]
      [(eq? 'utf-8-codec (transcoder-codec x))
       (fxior textual-output-port-bits fast-u7-text-tag)]
      [(eq? 'utf-16-codec (transcoder-codec x))
       (fxior textual-output-port-bits fast-u16be-text-tag)]
      [else (die who "unsupported codec" (transcoder-codec x))]))

  (define open-bytevector-input-port
    (case-lambda
      [(bv) (open-bytevector-input-port bv #f)]
      [(bv maybe-transcoder) 
       (unless (bytevector? bv) 
         (die 'open-bytevector-input-port 
                "not a bytevector" bv))
       (when (and maybe-transcoder
                  (not (transcoder? maybe-transcoder)))
         (die 'open-bytevector-input-port 
                "not a transcoder" maybe-transcoder))
       ($make-port 
          (input-transcoder-attrs maybe-transcoder
            'open-bytevector-output-port)
          0 (bytevector-length bv) bv 
          maybe-transcoder 
          "*bytevector-input-port*" 
          (lambda (bv i c) 0) ;;; read!
          #f ;;; write!
          #t ;;; get-position
          #t ;;; set-position!
          #f ;;; close
          #f
          (vector 0))]))

  (define open-bytevector-output-port
    (case-lambda
      [() (open-bytevector-output-port #f)]
      [(transcoder) 
       (define who 'open-bytevector-output-port)
       (unless (or (not transcoder) (transcoder? transcoder))
         (die who "invalid transcoder value" transcoder))
       (let ([buf* '()] [buffer-size 256])
         (let ([p 
                ($make-port 
                   (output-transcoder-attrs transcoder
                     'open-bytevector-output-port)
                   0 buffer-size (make-bytevector buffer-size)
                   transcoder
                   "*bytevector-output-port*"
                   #f
                   (lambda (bv i c) 
                     (unless (= c 0) 
                       (let ([x (make-bytevector c)])
                         (bytevector-copy! bv i x 0 c)
                         (set! buf* (cons x buf*))))
                     c)
                   #t ;;; get-position
                   #f ;;; set-position!
                   #f ;;; close
                   #f ;;; cookie
                   (vector 0))])
           (values
             p
             (lambda () 
               (define (append-bv-buf* ls) 
                 (let f ([ls ls] [i 0])
                   (cond
                     [(null? ls) 
                      (values (make-bytevector i) 0)]
                     [else 
                      (let* ([a (car ls)]
                             [n (bytevector-length a)])
                        (let-values ([(bv i) (f (cdr ls) (fx+ i n))])
                          (bytevector-copy! a 0 bv i n)
                          (values bv (fx+ i n))))])))
               (unless ($port-closed? p)
                 (flush-output-port p))
               (let-values ([(bv len) (append-bv-buf* buf*)])
                 (set! buf* '())
                 bv)))))]))

  (define call-with-bytevector-output-port
    (case-lambda
      [(proc) (call-with-bytevector-output-port proc #f)]
      [(proc transcoder) 
       (define who 'call-with-bytevector-output-port)
       (unless (procedure? proc) 
         (die who "not a procedure" proc))
       (unless (or (not transcoder) (transcoder? transcoder))
         (die who "invalid transcoder argument" transcoder))
       (let-values ([(p extract) 
                     (open-bytevector-output-port transcoder)])
         (proc p)
         (extract))]))

  (define (call-with-string-output-port proc)
    (define who 'call-with-string-output-port)
    (unless (procedure? proc) 
      (die who "not a procedure" proc))
    (let-values ([(p extract) (open-string-output-port)])
      (proc p)
      (extract)))

  (define (with-output-to-string proc) 
    (define who 'with-output-to-string)
    (unless (procedure? proc) 
      (die who "not a procedure" proc))
    (let-values ([(p extract) (open-string-output-port)])
      (parameterize ([current-output-port p])
        (proc))
      (extract)))

  (define (with-output-to-port p proc)
    (define who 'with-output-to-port)
    (unless (procedure? proc)
      (die who "not a procedure" proc))
    (unless (output-port? p) 
      (die who "not an output port" p))
    (unless (textual-port? p)
      (die who "not a textual port" p))
    (parameterize ([current-output-port p])
      (proc)))

  (define-struct output-string-cookie (strings))


  (define (open-output-string)
    (define who 'open-output-string)
    (let ([cookie (make-output-string-cookie '())]
          [buffer-size 256])
      ($make-port
         (fxior textual-output-port-bits fast-char-text-tag)
         0 buffer-size (make-string buffer-size)
         #t ;;; transcoder
         "*string-output-port*"
         #f
         (lambda (str i c) 
           (unless (= c 0) 
             (let ([x (make-string c)])
               (string-copy! str i x 0 c)
               (set-output-string-cookie-strings! cookie
                 (cons x (output-string-cookie-strings cookie)))))
           c)
         #t ;;; get-position
         #f ;;; set-position!
         #f ;;; close!
         cookie
         (vector 0))))

  (define (open-string-output-port)
    (let ([p (open-output-string)])
      (values
        p
        (lambda ()
          (let ([str (get-output-string p)])
            (set-output-string-cookie-strings!  ($port-cookie p) '())
            str)))))

  (define (get-output-string-cookie-data cookie)
    (define (append-str-buf* ls) 
      (let f ([ls ls] [i 0])
        (cond
          [(null? ls) 
           (values (make-string i) 0)]
          [else 
           (let* ([a (car ls)]
                  [n (string-length a)])
             (let-values ([(bv i) (f (cdr ls) (fx+ i n))])
               (string-copy! a 0 bv i n)
               (values bv (fx+ i n))))])))
      (let ([buf* (output-string-cookie-strings cookie)])
        (let-values ([(bv len) (append-str-buf* buf*)])
          bv)))

  (define (get-output-string p)
    (if (port? p) 
        (let ([cookie ($port-cookie p)])
          (cond
            [(output-string-cookie? cookie)
             (unless ($port-closed? p)
               (flush-output-port p))
             (get-output-string-cookie-data cookie)]
            [else
             (die 'get-output-string "not an output-string port" p)]))
        (die 'get-output-string "not a port" p)))

  

  (define (open-string-input-port/id str id)
    (unless (string? str) 
      (die 'open-string-input-port "not a string" str))
    ($make-port 
       (fxior textual-input-port-bits fast-char-text-tag)
       0 (string-length str) str
       #t ;;; transcoder
       id
       (lambda (str i c) 0) ;;; read!
       #f ;;; write!
       #t ;;; get-position
       #t ;;; set-position!
       #f ;;; close
       #f ;;; cookie
       (vector 0)))

  (define (open-string-input-port str)
    (open-string-input-port/id str "*string-input-port*"))

  (define (transcoded-port p transcoder)
    (define who 'transcoded-port)
    (unless (transcoder? transcoder)
      (die who "not a transcoder" transcoder))
    (unless (port? p) (die who "not a port" p))
    (when ($port-transcoder p) (die who "not a binary port" p))
    (when ($port-closed? p) (die who "cannot transcode closed port" p))
    (let ([read! ($port-read! p)]
          [write! ($port-write! p)])
      ($mark-port-closed! p)
      (guarded-port
        ($make-port 
          (cond
            [read! (input-transcoder-attrs transcoder
                     'transcoded-port)]
            [write! (output-transcoder-attrs transcoder
                      'transcoded-port)]
            [else
             (die 'transcoded-port 
               "port is neither input nor output!")])
          ($port-index p)
          ($port-size p)
          ($port-buffer p)
          transcoder
          ($port-id p)
          read!
          write!
          ($port-get-position p)
          ($port-set-position! p)
          ($port-close p)
          ($port-cookie p)
          (vector 0)))))

  (define (reset-input-port! p)
    (if (input-port? p) 
        (begin
          ($set-port-index! p ($port-size p))
          (unregister-callback p))
        (die 'reset-input-port! "not an input port" p)))

  (define (reset-output-port! p)
    (if (output-port? p) 
        (begin
          ($set-port-index! p 0)
          (unregister-callback p))
        (die 'reset-output-port! "not an output port" p)))


  (define (port-transcoder p)