From ea96ab85db0699ef06d01e9ace4e913a772397cc Mon Sep 17 00:00:00 2001
From: Abdulaziz Ghuloum <aghuloum@cs.indiana.edu>
Date: Sun, 9 Dec 2007 17:13:09 -0500
Subject: [PATCH] stage 1 of new input IO is almost complete.

---
 lab/io-spec.ss                        | 155 +++++++++++++++++++++-----
 lab/io-test.ss                        |  58 ++++++----
 scheme/ikarus.io-primitives.ss        |  34 ++++--
 scheme/ikarus.io-primitives.unsafe.ss |  13 ++-
 scheme/ikarus.io.input-files.ss       |   9 +-
 scheme/ikarus.io.input-strings.ss     |  34 +++---
 scheme/last-revision                  |   2 +-
 scheme/makefile.ss                    |   4 +-
 src/ikarus-io.c                       |   2 +-
 9 files changed, 229 insertions(+), 82 deletions(-)

diff --git a/lab/io-spec.ss b/lab/io-spec.ss
index 57d58b8..0fff140 100644
--- a/lab/io-spec.ss
+++ b/lab/io-spec.ss
@@ -2,43 +2,49 @@
 (library (io-spec) 
   
   (export 
-    input-port? output-port? textual-port? binary-port?
-    open-file-input-port standard-input-port current-input-port
+    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
     make-custom-binary-input-port 
     transcoded-port port-transcoder
-    close-port
+    close-port 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
     get-u8 lookahead-u8 
     get-bytevector-n get-bytevector-n!
     get-bytevector-some get-bytevector-all 
-    port-has-port-position? port-position
-    port-has-set-port-position!? set-port-position!
+    ;port-has-port-position? port-position
+    ;port-has-set-port-position!? set-port-position!
     call-with-port
+    flush-output-port
     )
 
   
   (import 
     (except (ikarus)
-      input-port? output-port? textual-port? binary-port? 
-      open-file-input-port standard-input-port current-input-port
+      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
       make-custom-binary-input-port
       transcoded-port port-transcoder
-      close-port
+      close-port 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
       get-u8 lookahead-u8 
       get-bytevector-n get-bytevector-n!
       get-bytevector-some get-bytevector-all 
-      port-has-port-position? port-position
-      port-has-set-port-position!? set-port-position!
+      ;port-has-port-position? port-position
+      ;port-has-set-port-position!? set-port-position!
       call-with-port
+      flush-output-port
       ))
 
   (define-syntax define-rrr
@@ -50,6 +56,7 @@
   (define-struct $port 
     (index size buffer base-index transcoder closed? attrs 
      id read! write! get-position set-position! close))
+  (define port? $port?)
   (define $set-port-index! set-$port-index!)
   (define $set-port-size! set-$port-size!)
   (define $set-port-attrs! set-$port-attrs!)
@@ -206,10 +213,25 @@
           (and (transcoder? tr) tr))
         (error 'port-transcoder "not a port" p)))
               
-  (define (close-port p)
+  (define (flush-output-port p)
+    (unless (output-port? p) 
+      (error 'flush-output-port "not an output port" p))
+    (when ($port-closed? p) 
+      (error 'flush-output-port "port is closed" p))
+    (let ([idx ($port-index p)] [size ($port-size p)])
+      (unless (fx= idx size)
+        (let ([cnt (fx- size idx)])
+         (let ([bytes (($port-write! p) ($port-buffer p) idx cnt)])
+           (unless (and (fixnum? bytes) (fx>= bytes 0) (fx<= bytes cnt))
+             (error 'flush-output-port 
+                    "write! returned an invalid value" 
+                    bytes))
+           ($set-port-index! p (fx+ idx bytes))
+           (unless (fx= bytes cnt)
+             (flush-output-port p)))))))
+
+  (define ($close-port p)
     (cond
-      [(not ($port? p)) 
-       (error 'close-port "not a port" p)]
       [($port-closed? p) (void)]
       [else
        (when ($port-write! p)
@@ -219,10 +241,25 @@
          (when (procedure? close)
            (close)))]))
 
-  (define-rrr port-has-port-position?)
-  (define-rrr port-position)
-  (define-rrr port-has-set-port-position!?)
-  (define-rrr set-port-position!)
+  (define (close-port p)
+    (unless ($port? p)
+       (error 'close-port "not a port" p))
+    ($close-port p))
+
+  (define (close-input-port p)
+    (unless (input-port? p)
+       (error 'close-input-port "not an input port" p))
+    ($close-port p))
+
+  (define (close-output-port p)
+    (unless (output-port? p)
+       (error 'close-output-port "not an output port" p))
+    ($close-port p))
+
+  ;(define-rrr port-has-port-position?)
+  ;(define-rrr port-position)
+  ;(define-rrr port-has-set-port-position!?)
+  ;(define-rrr set-port-position!)
 
   ;;; ----------------------------------------------------------
   (module (get-char lookahead-char)
@@ -502,7 +539,6 @@
            (eof-object? (advance-bom p who '(#xEF #xBB #xBF)))]
           [else (error 'slow-get-char "codec not handled")])))
 
-    (define-rrr slow-lookahead-char)
     (define (lookahead-char-char-mode p who)
       (let ([str ($port-buffer p)]
             [read! ($port-read! p)])
@@ -741,15 +777,86 @@
              (lambda (err) 
                (io-error 'close id err))])))))
 
-  (define-rrr open-file-input-port)
+  (define (open-file-handle filename who)
+    (let ([fh (foreign-call "ikrt_open_input_fd"
+                 (string->utf8 filename))])
+      (cond
+        [(fx< fh 0) (io-error who filename fh)]
+        [else fh])))
   
+
+  (define open-file-input-port
+    (case-lambda
+      [(filename) 
+       (open-file-input-port filename (file-options) 'block #f)]
+      [(filename file-options) 
+       (open-file-input-port filename file-options 'block #f)]
+      [(filename file-options buffer-mode) 
+       (open-file-input-port filename file-options buffer-mode #f)]
+      [(filename file-options buffer-mode transcoder)
+       (unless (string? filename)
+         (error 'open-file-input-port "invalid filename" filename))
+       ; FIXME: file-options ignored
+       ; FIXME: buffer-mode ignored
+       (fh->input-port 
+         (open-file-handle filename 'open-file-input-port) 
+         filename
+         file-buffer-size
+         (cond
+           [(or (not transcoder) (transcoder? transcoder)) 
+            transcoder]
+           [else (error 'open-file-input-port
+                        "invalid transcoder" 
+                        transcoder)])
+         #t)]))
+
+  (define (open-input-file filename)
+    (unless (string? filename)
+      (error 'open-input-file "invalid filename" filename))
+    (fh->input-port 
+       (open-file-handle filename 'open-input-file) 
+       filename
+       file-buffer-size
+       (native-transcoder)
+       #t))
+
+  (define (call-with-input-file filename proc)
+    (unless (string? filename)
+      (error 'call-with-input-file "invalid filename" filename))
+    (unless (procedure? proc)
+      (error 'call-with-input-file "not a procedure" proc))
+    (call-with-port
+      (fh->input-port 
+        (open-file-handle filename 'call-with-input-file) 
+        filename
+        file-buffer-size
+        (native-transcoder)
+        #t)
+      proc))
+
+  (define (with-input-from-file filename proc)
+    (unless (string? filename)
+      (error 'with-input-from-file "invalid filename" filename))
+    (unless (procedure? proc)
+      (error 'with-input-from-file "not a procedure" proc))
+    (let ([p
+           (fh->input-port 
+             (open-file-handle filename 'with-input-from-file) 
+             filename
+             file-buffer-size
+             (native-transcoder)
+             #t)])
+      (parameterize ([*the-input-port* p])
+        (proc))))
+
   (define (standard-input-port) 
     (fh->input-port 0 '*stdin* 256 #f #f))
 
   (define *the-input-port* 
-    (transcoded-port (standard-input-port) (native-transcoder)))
+    (make-parameter
+      (transcoded-port (standard-input-port) (native-transcoder))))
 
-  (define (current-input-port) *the-input-port*)
+  (define (current-input-port) (*the-input-port*))
 
   (define (call-with-port p proc)
     (if ($port? p) 
@@ -763,7 +870,7 @@
 
   (define read-char
     (case-lambda
-      [() (get-char *the-input-port*)]
+      [() (get-char (*the-input-port*))]
       [(p)
        (if (input-port? p)
            (if (textual-port? p)
@@ -773,14 +880,13 @@
   ;;;
   (define peek-char
     (case-lambda
-      [() (lookahead-char *the-input-port*)]
+      [() (lookahead-char (*the-input-port*))]
       [(p)
        (if (input-port? p)
            (if (textual-port? p)
                (lookahead-char p)
                (error 'peek-char "not a textual port" p))
            (error 'peek-char "not an input-port" p))]))
- 
 
   (define (get-bytevector-n p n) 
     (import (ikarus system $fx) (ikarus system $bytevectors))
@@ -817,7 +923,6 @@
       [($fx= n 0) '#vu8()]
       [else (error 'get-bytevector-n "count is negative" n)]))
 
-
   (define (get-bytevector-n! p s i c) 
     (import (ikarus system $fx) (ikarus system $bytevectors))
     (unless (input-port? p) 
diff --git a/lab/io-test.ss b/lab/io-test.ss
index bfc4932..42d6c6f 100755
--- a/lab/io-test.ss
+++ b/lab/io-test.ss
@@ -7,7 +7,9 @@
           input-port? open-string-input-port output-port?
           standard-input-port current-input-port
           get-bytevector-n get-bytevector-n!
-          get-string-n get-string-n! get-line)
+          get-string-n get-string-n! get-line port?
+          close-input-port close-output-port flush-output-port
+          open-input-file call-with-input-file with-input-from-file)
 
   (io-spec))
 
@@ -368,29 +370,41 @@
       (make-utf8-string-range4))))
 
 
-(display "now write something on the keyboard ...\n")
-(printf "you typed ~s\n"
-  (list->string
-    (let ([p (standard-input-port)])
-      (let f ()
-        (let ([x (get-u8 p)])
-          (if (eof-object? x) 
-              '()
-              (cons (integer->char x) (f))))))))
+(define (run-interactive-tests)
+  (display "now write something on the keyboard ...\n")
+  (printf "you typed ~s\n"
+    (list->string
+      (let ([p (standard-input-port)])
+        (let f ()
+          (let ([x (get-u8 p)])
+            (if (eof-object? x) 
+                '()
+                (cons (integer->char x) (f))))))))
+  
+  (display "let's do it again ...\n")
+  (printf "you typed ~s\n"
+    (list->string
+      (let ([p (transcoded-port (standard-input-port)
+                  (make-transcoder (utf-8-codec)))])
+        (let f ()
+          (let ([x (get-char p)])
+            (if (eof-object? x) 
+                '()
+                (cons x (f)))))))))
+  
+(define (file-size filename)
+  (with-input-from-file filename
+    (lambda ()
+      (let f ([i 0])
+        (let ([x (get-char (current-input-port))])
+          (if (eof-object? x)
+              i
+              (f (+ i 1))))))))
 
-(display "let's do it again ...\n")
-(printf "you typed ~s\n"
-  (list->string
-    (let ([p (transcoded-port (standard-input-port)
-                (make-transcoder (utf-8-codec)))])
-      (let f ()
-        (let ([x (get-char p)])
-          (if (eof-object? x) 
-              '()
-              (cons x (f))))))))
+(assert (= (file-size "SRFI-1.ss") 56573))
 
 
 
+;(run-exhaustive-tests)
+;(run-interactive-tests)
 
-
-(run-exhaustive-tests)
diff --git a/scheme/ikarus.io-primitives.ss b/scheme/ikarus.io-primitives.ss
index 038f522..0eb8778 100644
--- a/scheme/ikarus.io-primitives.ss
+++ b/scheme/ikarus.io-primitives.ss
@@ -15,14 +15,32 @@
 
 
 (library (ikarus io-primitives)
-  (export read-char peek-char write-char write-byte
-          put-u8 put-char put-string put-bytevector 
-          get-char get-u8 lookahead-u8
-          get-string-n get-string-n! 
-          get-bytevector-n get-bytevector-n!
-          newline port-name input-port-name output-port-name
-          close-input-port reset-input-port! close-port
-          flush-output-port close-output-port get-line)
+  (export read-char           ; ok
+          peek-char           ; ok
+          write-char 
+          write-byte 
+          put-u8 
+          put-char
+          put-string 
+          put-bytevector    
+          get-char            ; ok
+          get-u8              ; ok
+          lookahead-u8        ; ok
+          get-string-n        ; ok
+          get-string-n!       ; ok
+          get-bytevector-n    ; ok
+          get-bytevector-n!   ; ok
+          newline             ; ok
+          port-name 
+          input-port-name 
+          output-port-name
+          close-input-port
+          reset-input-port! 
+          close-port
+          flush-output-port 
+          close-output-port 
+          get-line            ; ok
+          )
   (import 
     (ikarus system $io)
     (ikarus system $fx)
diff --git a/scheme/ikarus.io-primitives.unsafe.ss b/scheme/ikarus.io-primitives.unsafe.ss
index ee142af..9d10124 100644
--- a/scheme/ikarus.io-primitives.unsafe.ss
+++ b/scheme/ikarus.io-primitives.unsafe.ss
@@ -15,10 +15,17 @@
 
 
 (library (ikarus io-primitives unsafe)
-  (export $write-char $write-byte $read-char $get-u8 $lookahead-u8
+  (export $write-char 
+          $write-byte
+          $read-char
+          $get-u8 
+          $lookahead-u8
           $peek-char
-          $reset-input-port! $flush-output-port 
-          $close-input-port $close-output-port)
+          $reset-input-port!
+          $flush-output-port 
+          $close-input-port
+          $close-output-port
+          )
   (import
     (ikarus)
     (ikarus system $ports)
diff --git a/scheme/ikarus.io.input-files.ss b/scheme/ikarus.io.input-files.ss
index 1b31abf..a5f783e 100644
--- a/scheme/ikarus.io.input-files.ss
+++ b/scheme/ikarus.io.input-files.ss
@@ -15,8 +15,13 @@
 
 
 (library (ikarus io input-files)
-  (export open-input-file current-input-port console-input-port
-          standard-input-port with-input-from-file call-with-input-file)
+  (export open-input-file
+          current-input-port   ; ok?
+          console-input-port
+          standard-input-port  ; ok
+          with-input-from-file 
+          call-with-input-file
+          )
   (import
     (ikarus system $ports)
     (ikarus system $io)
diff --git a/scheme/ikarus.io.input-strings.ss b/scheme/ikarus.io.input-strings.ss
index b6a3a66..2a2c707 100644
--- a/scheme/ikarus.io.input-strings.ss
+++ b/scheme/ikarus.io.input-strings.ss
@@ -15,7 +15,7 @@
 
 
 (library (ikarus io input-strings)
-  (export open-input-string open-string-input-port with-input-from-string)
+  (export open-string-input-port)
   (import 
     (ikarus system $strings)
     (ikarus system $bytevectors)
@@ -23,9 +23,7 @@
     (ikarus system $pairs)
     (ikarus system $ports)
     (ikarus system $io)
-    (except (ikarus)
-      open-input-string open-string-input-port 
-      with-input-from-string))
+    (except (ikarus) open-string-input-port ))
  
   (define-syntax message-case
     (syntax-rules (else)
@@ -82,11 +80,11 @@
                     '#vu8())])
         port))
 
-  (define open-input-string
-    (lambda (str)
-      (unless (string? str)
-        (error 'open-input-string "not a string" str))
-      ($open-input-string str)))
+  ;(define open-input-string
+  ;  (lambda (str)
+  ;    (unless (string? str)
+  ;      (error 'open-input-string "not a string" str))
+  ;    ($open-input-string str)))
 
   (define open-string-input-port
     (lambda (str)
@@ -94,15 +92,15 @@
         (error 'open-string-input-port "not a string" str))
       ($open-input-string str)))
 
-  (define with-input-from-string
-     (lambda (str proc)
-       (unless (string? str) 
-         (error 'with-input-from-string "not a string" str))
-       (unless (procedure? proc)
-         (error 'with-input-from-string "not a procedure" proc))
-       (let ([p (open-input-string str)])
-         (parameterize ([current-input-port p])
-           (proc)))))
+  ;(define with-input-from-string
+  ;   (lambda (str proc)
+  ;     (unless (string? str) 
+  ;       (error 'with-input-from-string "not a string" str))
+  ;     (unless (procedure? proc)
+  ;       (error 'with-input-from-string "not a procedure" proc))
+  ;     (let ([p ($open-input-string str)])
+  ;       (parameterize ([current-input-port p])
+  ;         (proc)))))
 
   )
 
diff --git a/scheme/last-revision b/scheme/last-revision
index 44acfeb..87577dc 100644
--- a/scheme/last-revision
+++ b/scheme/last-revision
@@ -1 +1 @@
-1201
+1202
diff --git a/scheme/makefile.ss b/scheme/makefile.ss
index 2012de8..9e661ae 100755
--- a/scheme/makefile.ss
+++ b/scheme/makefile.ss
@@ -342,10 +342,10 @@
     [output-port-name                            i]
     [port-mode                                   i]
     [set-port-mode!                              i]
-    [with-input-from-string                      i]
+    ;[with-input-from-string                      i]
     [open-output-string                          i]
     [open-output-bytevector                      i]
-    [open-input-string                           i]
+    ;[open-input-string                           i]
     [get-output-string                           i]
     [get-output-bytevector                       i]
     [with-output-to-string                       i]
diff --git a/src/ikarus-io.c b/src/ikarus-io.c
index bd0c0ee..04c242a 100644
--- a/src/ikarus-io.c
+++ b/src/ikarus-io.c
@@ -47,7 +47,7 @@ ikrt_close_fd(ikp fd, ikpcb* pcb){
 
 ikp
 ikrt_open_input_fd(ikp fn, ikpcb* pcb){
-  int fh = open((char*)(fn+off_bytevector_data, O_RDONLY), 0);
+  int fh = open((char*)(fn+off_bytevector_data), O_RDONLY, 0);
   if(fh > 0){
     return fix(fh);
   } else {