Exported the transcoder? primitive.

lab/io-prims.ss

@@ -1,9 +0,0 @@
-
-(library (io-prims) 
-  (export )
-  (import 
-    (io-spec)  
-    (except (ikarus)))
-
-
-  )

lab/io-spec.ss

@@ -1,12 +1,25 @@
 
 (library (io-spec) 
-  (export )
+  (export 
+    input-port? textual-port? port-eof?
+    open-bytevector-input-port
+    make-custom-binary-input-port 
+    get-char lookahead-char get-u8 lookahead-u8 close-port)
   (import 
-    (except (ikarus) get-char get-u8 put-char put-u8))
+    (except (ikarus)
+      input-port? textual-port? port-eof?
+      open-bytevector-input-port
+      make-custom-binary-input-port
+      get-char lookahead-char get-u8 lookahead-u8 close-port))
 
   (define-struct $port 
-    (index size buffer base-index codec closed? handlers attrs))
+    (index size buffer base-index codec closed? attrs 
+     id read! write! get-position set-position! close))
   (define $set-port-index! set-$port-index!)
+  (define $set-port-size! set-$port-size!)
+  (define $set-port-attrs! set-$port-attrs!)
+  (define $set-port-closed?! set-$port-closed?!)
+  (define $make-port make-$port)
 
   (define fast-get-tag           #x0001)
   (define fast-put-tag           #x0002)
@@ -38,8 +51,82 @@
   ;;; everything above this line will turn into primitive
   ;;; ----------------------------------------------------------
   
-  (define-struct handler
+
-    (data id read! write! get-position set-position! close))
+
+  (define ($make-custom-binary-input-port id 
+            read! get-position set-position! close buffer-size)
+    (let ([bv (make-bytevector buffer-size)])
+      ($make-port 0 0 bv 0 #f #f 0 id read! #f get-position
+                  set-position! close)))
+
+  (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)
+      (error who "id is not a string" id))
+    (unless (procedure? read!)
+      (error who "read! is not a procedure" read!))
+    (unless (or (procedure? close) (not close))
+      (error who "close should be either a procedure or #f" close))
+    ($make-custom-binary-input-port id read! get-position
+      set-position! close 256))
+
+  (define (transcoder-attrs x)
+    (import (ikarus system $transcoders))
+    (cond
+      [(not x) ;;; binary
+       (fxior fast-get-tag fast-get-byte-tag)]
+      [else 
+       (error 'transcoder-attrs "not handled" x)]))
+
+
+  (define open-bytevector-input-port
+    (case-lambda
+      [(bv) (open-bytevector-input-port bv #f)]
+      [(bv maybe-transcoder) 
+       (import (ikarus system $transcoders))
+       (unless (bytevector? bv) 
+         (error 'open-bytevector-input-port 
+                "not a bytevector" bv))
+       (when (and maybe-transcoder
+                  (not ($transcoder? maybe-transcoder)))
+         (error 'open-bytevector-input-port 
+                "not a transcoder" maybe-transcoder))
+       ($make-port 0 (bytevector-length bv) bv 0 
+          maybe-transcoder 
+          #f ;;; closed?
+          (transcoder-attrs maybe-transcoder)
+          "*bytevector-input-port*" 
+          (lambda (bv i c) 0) ;;; read!
+          #f ;;; write!
+          #f ;;; FIXME: get-position
+          #f ;;; FIXME: set-position!
+          #f ;;; close
+          )]))
+
+  (define (input-port? p) 
+    (and ($port? p) 
+         ($port-read! p) 
+         #t))
+
+  (define (textual-port? p) 
+    (and ($port? p) 
+         ($port-codec p) 
+         #t))
+
+  (define (close-port p)
+    (cond
+      [(not ($port? p)) 
+       (error 'close-port "not a port" p)]
+      [($port-closed? p) (void)]
+      [else
+       (when ($port-write! p)
+         (flush-output-port p))
+       ($set-port-closed?! p #t)
+       (let ([close ($port-close p)])
+         (when (procedure? close)
+           (close)))]))
 
   (define-syntax define-rrr
     (syntax-rules ()
@@ -48,11 +135,12 @@
          (error 'name "not implemented" args))]))
 
   ;;; ----------------------------------------------------------
-  (module (get-char)
+  (module (get-char lookahead-char)
     (define-rrr get-char-utf8-mode)
     (define-rrr get-char-latin-mode)
     (define-rrr get-char-char-mode)
     (define-rrr slow-get-char)
+    (define-rrr lookahead-char)
     ;;;
     (define (get-char p)
       (define who 'get-char)
@@ -90,9 +178,35 @@
           [else (slow-get-char p who)]))))
 
   ;;; ----------------------------------------------------------
-  (module (get-u8)
+  (define (assert-binary-input-port p who)
-    (define-rrr get-u8-byte-mode)
+    (unless ($port? p) (error who "not a port" p))
-    (define-rrr slow-get-u8)
+    (when ($port-closed? p) (error who "port is closed" p))
+    (when ($port-codec p) (error who "port is not binary" p))
+    (unless ($port-read! p)
+      (error who "port is not an input port" p)))
+
+  (module (get-u8 lookahead-u8)
+    (define (get-u8-byte-mode p who start) 
+      (when ($port-closed? p) (error who "port is closed" p))
+      (let* ([bv ($port-buffer p)]
+             [n (bytevector-length bv)])
+        (let ([j (($port-read! p) bv 0 n)])
+          (unless (fixnum? j)
+            (error who "invalid return value from read! procedure" j))
+          (cond
+            [(fx> j 0) 
+             (unless (fx<= j n)
+               (error who "read! returned a value out of range" j))
+             ($set-port-index! p start) 
+             ($set-port-size! p j)
+             (bytevector-u8-ref bv 0)]
+            [(fx= j 0) (eof-object)]
+            [else 
+             (error who "read! returned a value out of range" j)]))))
+    (define (slow-get-u8 p who start) 
+      (assert-binary-input-port p who)
+      ($set-port-attrs! p (fxior fast-get-tag fast-get-byte-tag))
+      (get-u8-byte-mode p who start))
     ;;;
     (define (get-u8 p)
       (define who 'get-u8)
@@ -104,8 +218,48 @@
                [(fx< i ($port-size p))
                 ($set-port-index! p (fx+ i 1))
                 (bytevector-u8-ref ($port-buffer p) i)]
-               [else (get-u8-byte-mode p who)]))]
+               [else (get-u8-byte-mode p who 1)]))]
-          [else (slow-get-u8 p who)]))))
+          [else (slow-get-u8 p who 1)])))
+    (define (lookahead-u8 p)
+      (define who 'lookahead-u8)
+      (let ([m ($port-get-mode p)])
+        (cond
+          [(eq? m fast-get-byte-tag)
+           (let ([i ($port-index p)])
+             (cond
+               [(fx< i ($port-size p))
+                (bytevector-u8-ref ($port-buffer p) i)]
+               [else (get-u8-byte-mode p who 0)]))]
+          [else (slow-get-u8 p who 0)]))))
+
+  (define (port-eof? p)
+    (define who 'port-eof?)
+    (let ([m ($port-get-mode p)])
+      (cond
+        [(not (eq? m 0))
+         (if (fx< ($port-index p) ($port-size p))
+             #f
+             (if ($port-codec p) 
+                 (eof-object? (lookahead-char p))
+                 (eof-object? (lookahead-u8 p))))]
+        [(input-port? p)
+         (when ($port-closed? p) 
+           (error 'port-eof? "port is closed" p))
+         (if (textual-port? p) 
+             (eof-object? (lookahead-char p))
+             (eof-object? (lookahead-u8 p)))]
+        [else (error 'port-eof? "not an input port" p)])))
+
+
+
+  )
+
+
+
+#!eof
+ 
+  ;;; ----------------------------------------------------------
+  ;;; do input ports first.
   
   ;;; ----------------------------------------------------------
   (module (put-char)
@@ -147,7 +301,6 @@
                   (put-char-latin-mode p b who)])))]
           [else (slow-put-char p c who)]))))
 
-  ;;; ----------------------------------------------------------
   (module (put-u8)
     (define-rrr put-u8-byte-mode)
     (define-rrr slow-put-u8)
@@ -166,7 +319,3 @@
                [else
                 (put-u8-byte-mode p b who)]))]
           [else (slow-put-u8 p b who)]))))
-
-  ;;; that's it for today.  see you tomorrow .
-
-  )

lab/io-test.ss

@@ -0,0 +1,108 @@
+#!/usr/bin/env scheme-script
+
+(import 
+  (except (ikarus) get-char get-u8 lookahead-u8 close-port input-port?)
+  (io-spec))
+
+(define-syntax test
+  (syntax-rules ()
+    [(_ name body) 
+     (begin
+       (printf "running ~s ..." 'name)
+       body
+       (printf " ok\n"))]))
+
+(define (make-n-byte-custom-binary-input-port n)
+  (assert (<= 0 n 256))
+  (make-custom-binary-input-port "test0" 
+     (let ([c 0])
+       (lambda (bv i count) 
+         (if (< c n) 
+             (begin
+               (bytevector-u8-set! bv i c)
+               (set! c (+ c 1))
+               1)
+             0)))
+     #f #f #f))
+
+(define (make-n-byte-bytevector-binary-input-port n)
+  (assert (<= 0 n 256))
+  (let ([bv (make-bytevector n)])
+    (let f ([i 0]) 
+      (unless (= i n)
+        (bytevector-u8-set! bv i i)
+        (f (+ i 1))))
+    (open-bytevector-input-port bv)))
+
+(define (test-get-u8-1 p n)
+  (let f ([i 0])
+    (let ([x (get-u8 p)])
+      (cond
+        [(eof-object? x)
+         (unless (= i n) 
+           (error 'test0 "premature termination" i))]
+        [(= x i) (f (+ i 1))]
+        [else 
+         (error 'test0 "incorrect value returned" x)]))))
+
+(define (test-peek-u8-1 p n)
+  (let f ([i 0])
+    (let* ([px (lookahead-u8 p)]
+           [x (get-u8 p)])
+      (cond
+        [(not (eqv? px x)) (error #f "peek invalid" px x)]
+        [(eof-object? x)
+         (unless (= i n) 
+           (error #f "premature termination" i))]
+        [(= x i) (f (+ i 1))]
+        [else 
+         (error #f "incorrect value returned" x i)]))))
+
+(define (test-port-eof?-1 p n)
+  (let f ([i 0])
+    (cond
+      [(port-eof? p)
+       (unless (= i n)
+         (error #f "premature termination" i))
+       (assert (eof-object? (lookahead-u8 p)))
+       (assert (eof-object? (get-u8 p)))]
+      [(= (get-u8 p) i) (f (+ i 1))]
+      [else 
+       (error #f "incorrect value returned" i)])))
+
+(test "reading 256 bytes in ascending order"
+  (test-get-u8-1 (make-n-byte-custom-binary-input-port 256) 256))
+
+(test "reading 256 bytes in ascending order 2 at a time"
+  (test-get-u8-1
+    (make-custom-binary-input-port "test0" 
+      (let ([c 0])
+        (lambda (bv i count) 
+          (if (< c 256) 
+              (begin
+                (assert (>= count 2))
+                (bytevector-u8-set! bv i c)
+                (bytevector-u8-set! bv (+ i 1) (+ c 1))
+                (set! c (+ c 2))
+                2)
+              0)))
+      #f #f #f)
+    256))
+
+(test "peeking 256 bytes in ascending order"
+  (test-peek-u8-1 (make-n-byte-custom-binary-input-port 256) 256))
+
+(test "custom-binary-port port-eof?"
+  (test-port-eof?-1 (make-n-byte-custom-binary-input-port 256) 256))
+
+;;;
+(test "reading 256 bytes from bytevector-input-port"
+  (test-get-u8-1 (make-n-byte-bytevector-binary-input-port 256) 256))
+
+(test "peeking 256 bytes from bytevector-input-port"
+  (test-peek-u8-1 (make-n-byte-bytevector-binary-input-port 256) 256))
+
+(test "bytevector-binary-port port-eof?"
+  (test-port-eof?-1 (make-n-byte-bytevector-binary-input-port 256) 256))
+
+

lab/test-io.ss

@@ -1,6 +0,0 @@
-#!/usr/bin/env scheme-script
-
-(import 
-  (except (ikarus))
-  (io-spec))
-

scheme/ikarus.codecs.ss

@@ -91,7 +91,7 @@
 
   (define (transcoder-codec x) 
     (define who 'transcoder-codec)
-    (if ($transcoder? x) 
+    (if (transcoder? x) 
         (let ([tag (fxlogand ($transcoder->data x) codec-mask)])
           (or (rev-lookup tag codec-alist)
               (error who "transcoder has no codec" x)))
@@ -99,7 +99,7 @@
 
   (define (transcoder-eol-style x) 
     (define who 'transcoder-eol-style)
-    (if ($transcoder? x) 
+    (if (transcoder? x) 
         (let ([tag (fxlogand ($transcoder->data x) eol-style-mask)])
           (or (rev-lookup tag eol-style-alist)
               (error who "transcoder has no eol-style" x)))
@@ -107,7 +107,7 @@
 
   (define (transcoder-error-handling-mode x) 
     (define who 'transcoder-error-handling-mode)
-    (if ($transcoder? x) 
+    (if (transcoder? x) 
         (let ([tag (fxlogand ($transcoder->data x) error-handling-mode-mask)])
           (or (rev-lookup tag error-handling-mode-alist)
               (error who "transcoder has no error-handling mode" x)))

scheme/ikarus.predicates.ss

@@ -22,14 +22,14 @@
           symbol? code? not weak-pair? eq? eqv? equal? boolean=?
           symbol=? finite? infinite? nan? real-valued?
           rational-valued? integer-valued? 
-          output-port? input-port? port?)
+          output-port? input-port? port? transcoder?)
 
   (import 
     (except (ikarus) fixnum? flonum? bignum? ratnum? number? complex? real?
             rational? integer? exact? inexact? eof-object? bwp-object?
             immediate? boolean? char? vector? bytevector? string? procedure?
             null? pair? weak-pair? symbol? code? not eq? eqv? equal?
-            port? input-port? output-port? boolean=? symbol=?
+            transcoder? port? input-port? output-port? boolean=? symbol=?
             finite? infinite? nan? real-valued? rational-valued? 
             integer-valued?)
     (ikarus system $fx)
@@ -41,6 +41,7 @@
     (rename (only (ikarus) fixnum? flonum? bignum? ratnum? eof-object?
                   bwp-object? immediate? boolean? char? vector? string?
                   bytevector? procedure? null? pair? symbol? code? eq?
+                  transcoder?
                   port? input-port? output-port?)
             (fixnum? sys:fixnum?)
             (flonum? sys:flonum?)
@@ -60,6 +61,7 @@
             (symbol? sys:symbol?)
             (code? sys:code?)
             (eq? sys:eq?)
+            (transcoder? sys:transcoder?)
             (port? sys:port?)
             (input-port? sys:input-port?)
             (output-port? sys:output-port?)
@@ -173,6 +175,7 @@
 
   (define eof-object? (lambda (x) (sys:eof-object? x)))
   (define bwp-object? (lambda (x) (sys:bwp-object? x)))
+  (define transcoder? (lambda (x) (sys:transcoder? x)))
   (define immediate? (lambda (x) (sys:immediate? x)))
   (define boolean? (lambda (x) (sys:boolean? x)))
   (define char? (lambda (x) (sys:char? x)))

scheme/ikarus.writer.ss

@@ -589,7 +589,7 @@
         [(number? x)
          (write-char* (number->string x) p)
          i]
-        [($transcoder? x) 
+        [(transcoder? x)
          (write-char* "#<transcoder " p)
          (let ([n ($transcoder->data x)])
            (write-char* (number->string n) p))

scheme/last-revision

@@ -1 +1 @@
-1187
+1190

scheme/makefile.ss

@@ -1133,6 +1133,7 @@
     [make-transcoder                             i r ip]
     [native-eol-style                            i r ip]
     [native-transcoder                           i r ip]
+    [transcoder?                                 i]
     [open-bytevector-input-port                  r ip]
     [open-bytevector-output-port                 i r ip]
     [open-file-input-port                        r ip]
@@ -1298,7 +1299,6 @@
     [library                                     i]
     [syntax-dispatch                             ]
     [syntax-error                                i r sc]
-    [$transcoder?                                $transc]
     [$transcoder->data                           $transc]
     [$data->transcoder                           $transc]
     [file-options-spec                           i]

scheme/pass-specify-rep-primops.ss

@@ -1964,8 +1964,10 @@
 /section)
 
 (section ; transcoders
-(define-primop $transcoder? unsafe
+
+(define-primop transcoder? unsafe
   [(P x) (tag-test (T x) transcoder-mask transcoder-tag)])
+
 (define-primop $data->transcoder unsafe
   [(V x) (prm 'logor
               (prm 'sll (T x) (K (- transcoder-payload-shift fixnum-shift)))