bytevector ports for r7rs egg pasted by sethalves on Tue Apr 1 19:15:55 2014

Index: scheme.base.scm
===================================================================
--- scheme.base.scm	(revision 30632)
+++ scheme.base.scm	(working copy)
@@ -23,6 +23,9 @@
                 (make-u8vector make-bytevector)
                 (write-u8vector write-bytevector)))
 
+(import (only srfi-1 fold))
+(import (only ports make-input-port make-output-port))
+
 (%include "scheme.base-interface.scm")
 
 ;; For syntax definition helpers.
@@ -784,4 +787,60 @@
       ((bv port start end)
        (read-u8vector!/eof (fx- end start) bv port start)))))
 
+(define (open-input-bytevector bv)
+  (let ((index 0))
+    (make-input-port
+     (lambda () ; read-char
+       (cond ((= index (bytevector-length bv)) (eof-object))
+             (else
+              (let ((c (bytevector-u8-ref bv index)))
+                (set! index (+ index 1))
+                (integer->char c)))))
+     (lambda () ; char-ready?
+       (not (= index (bytevector-length bv))))
+     (lambda () #t) ; close
+     (lambda () ; peek-char
+       (if (= index (bytevector-length bv))
+           (eof-object)
+           (bytevector-u8-ref bv index))))))
+
+(define (open-output-bytevector)
+  (let* ((segments (list '()))
+         (p (make-output-port
+             (lambda (s) ;; write
+               (let ((bv (make-bytevector (string-length s))))
+                 (let loop ((i 0))
+                   (cond ((= i (string-length s))
+                          (cons bv segments))
+                         (else
+                          (bytevector-u8-set!
+                           bv i (char->integer (string-ref s i)))
+                          (loop (+ i 1)))))
+                 (set-car! segments (cons bv (car segments)))))
+             (lambda () ;; close
+               #t))))
+    (##sys#setslot p 3 segments)
+    p))
+
+(define (sum-bytevector-list-sizes bv-lst)
+  (fold + 0 (map bytevector-length bv-lst)))
+
+(define (reverse-bytevector-list->bytevector bv-lst)
+  ;; reverse a list of bytevectors and combine them into
+  ;; a single bytevector
+  (let* ((data-size (sum-bytevector-list-sizes bv-lst))
+         (result (make-bytevector data-size)))
+    (let loop ((bv-lst bv-lst)
+               (result-i data-size))
+      (cond ((null? bv-lst) result)
+            (else
+             (let* ((bv (car bv-lst))
+                    (new-result-i (- result-i (bytevector-length bv))))
+               (bytevector-copy! result new-result-i bv)
+               (loop (cdr bv-lst) new-result-i)))))))
+
+(define (get-output-bytevector p)
+  (let ((segments (car (##sys#slot p 3))))
+    (reverse-bytevector-list->bytevector segments)))
+
 )
Index: tests/run.scm
===================================================================
--- tests/run.scm	(revision 30632)
+++ tests/run.scm	(working copy)
@@ -973,6 +973,21 @@
                  (import (scheme base))
                  (begin (eq? numbers#+ +)))))
 
+
+(test-group "open-input-bytevector"
+  (test (bytevector 0 1 2 10 13 40 41 42 128 140 240 255)
+        (let ((bv (bytevector 0 1 2 10 13 40 41 42 128 140 240 255)))
+          (read-bytevector 12 (open-input-bytevector bv)))))
+
+(test-group "open-output-bytevector"
+  (test (bytevector 0 1 2 10 13 40 41 42 128 140 240 255)
+        (let ((p (open-output-bytevector)))
+          (write-bytevector (bytevector 0 1 2 10 13) p)
+          (write-bytevector (bytevector 40 41 42 128) p)
+          (write-bytevector (bytevector 140 240 255) p)
+          (close-output-port p)
+          (get-output-bytevector p))))
+
 (test-end "r7rs tests")
 
 (test-exit)
Index: scheme.base-interface.scm
===================================================================
--- scheme.base-interface.scm	(revision 30632)
+++ scheme.base-interface.scm	(working copy)
@@ -58,9 +58,7 @@
   flush-output-port
   for-each
   gcd lcm
-  #|
   get-output-bytevector
-  |#
   get-output-string
   guard
   if
@@ -96,9 +94,7 @@
   null?
   number->string string->number
   number?
-  #|
   open-input-bytevector open-output-bytevector
-  |#
   open-input-string open-output-string
   or
   pair?
[ permalink | raw ]

bytevector ports for r7rs egg revised pasted by sethalves on Tue Apr 1 19:29:13 2014

Index: scheme.base.scm
===================================================================
--- scheme.base.scm	(revision 30632)
+++ scheme.base.scm	(working copy)
@@ -23,6 +23,9 @@
                 (make-u8vector make-bytevector)
                 (write-u8vector write-bytevector)))
 
+(import (only srfi-1 fold))
+(import (only ports make-input-port make-output-port))
+
 (%include "scheme.base-interface.scm")
 
 ;; For syntax definition helpers.
@@ -784,4 +787,26 @@
       ((bv port start end)
        (read-u8vector!/eof (fx- end start) bv port start)))))
 
+(define (open-input-bytevector bv)
+  (let ((index 0))
+    (make-input-port
+     (lambda () ; read-char
+       (cond ((= index (bytevector-length bv)) (eof-object))
+             (else
+              (let ((c (bytevector-u8-ref bv index)))
+                (set! index (+ index 1))
+                (integer->char c)))))
+     (lambda () ; char-ready?
+       (not (= index (bytevector-length bv))))
+     (lambda () #t) ; close
+     (lambda () ; peek-char
+       (if (= index (bytevector-length bv))
+           (eof-object)
+           (bytevector-u8-ref bv index))))))
+
+(define open-output-bytevector open-output-string)
+
+(define (get-output-bytevector p)
+  (string->utf8 (get-output-string p)))
+
 )
Index: tests/run.scm
===================================================================
--- tests/run.scm	(revision 30632)
+++ tests/run.scm	(working copy)
@@ -973,6 +973,21 @@
                  (import (scheme base))
                  (begin (eq? numbers#+ +)))))
 
+
+(test-group "open-input-bytevector"
+  (test (bytevector 0 1 2 10 13 40 41 42 128 140 240 255)
+        (let ((bv (bytevector 0 1 2 10 13 40 41 42 128 140 240 255)))
+          (read-bytevector 12 (open-input-bytevector bv)))))
+
+(test-group "open-output-bytevector"
+  (test (bytevector 0 1 2 10 13 40 41 42 128 140 240 255)
+        (let ((p (open-output-bytevector)))
+          (write-bytevector (bytevector 0 1 2 10 13) p)
+          (write-bytevector (bytevector 40 41 42 128) p)
+          (write-bytevector (bytevector 140 240 255) p)
+          (close-output-port p)
+          (get-output-bytevector p))))
+
 (test-end "r7rs tests")
 
 (test-exit)
Index: scheme.base-interface.scm
===================================================================
--- scheme.base-interface.scm	(revision 30632)
+++ scheme.base-interface.scm	(working copy)
@@ -58,9 +58,7 @@
   flush-output-port
   for-each
   gcd lcm
-  #|
   get-output-bytevector
-  |#
   get-output-string
   guard
   if
@@ -96,9 +94,7 @@
   null?
   number->string string->number
   number?
-  #|
   open-input-bytevector open-output-bytevector
-  |#
   open-input-string open-output-string
   or
   pair?
[ permalink | raw ]

bytevector ports for r7rs egg revised revised pasted by sethalves on Tue Apr 1 19:35:19 2014

Index: scheme.base-interface.scm
===================================================================
--- scheme.base-interface.scm	(revision 30632)
+++ scheme.base-interface.scm	(working copy)
@@ -58,9 +58,7 @@
   flush-output-port
   for-each
   gcd lcm
-  #|
   get-output-bytevector
-  |#
   get-output-string
   guard
   if
@@ -96,9 +94,7 @@
   null?
   number->string string->number
   number?
-  #|
   open-input-bytevector open-output-bytevector
-  |#
   open-input-string open-output-string
   or
   pair?
Index: scheme.base.scm
===================================================================
--- scheme.base.scm	(revision 30632)
+++ scheme.base.scm	(working copy)
@@ -23,6 +23,8 @@
                 (make-u8vector make-bytevector)
                 (write-u8vector write-bytevector)))
 
+(import (only ports make-input-port make-output-port))
+
 (%include "scheme.base-interface.scm")
 
 ;; For syntax definition helpers.
@@ -784,4 +786,26 @@
       ((bv port start end)
        (read-u8vector!/eof (fx- end start) bv port start)))))
 
+(define (open-input-bytevector bv)
+  (let ((index 0))
+    (make-input-port
+     (lambda () ; read-char
+       (cond ((= index (bytevector-length bv)) (eof-object))
+             (else
+              (let ((c (bytevector-u8-ref bv index)))
+                (set! index (+ index 1))
+                (integer->char c)))))
+     (lambda () ; char-ready?
+       (not (= index (bytevector-length bv))))
+     (lambda () #t) ; close
+     (lambda () ; peek-char
+       (if (= index (bytevector-length bv))
+           (eof-object)
+           (bytevector-u8-ref bv index))))))
+
+(define (open-output-bytevector) (open-output-string))
+
+(define (get-output-bytevector p)
+  (string->utf8 (get-output-string p)))
+
 )
Index: tests/run.scm
===================================================================
--- tests/run.scm	(revision 30632)
+++ tests/run.scm	(working copy)
@@ -973,6 +973,21 @@
                  (import (scheme base))
                  (begin (eq? numbers#+ +)))))
 
+
+(test-group "open-input-bytevector"
+  (test (bytevector 0 1 2 10 13 40 41 42 128 140 240 255)
+        (let ((bv (bytevector 0 1 2 10 13 40 41 42 128 140 240 255)))
+          (read-bytevector 12 (open-input-bytevector bv)))))
+
+(test-group "open-output-bytevector"
+  (test (bytevector 0 1 2 10 13 40 41 42 128 140 240 255)
+        (let ((p (open-output-bytevector)))
+          (write-bytevector (bytevector 0 1 2 10 13) p)
+          (write-bytevector (bytevector 40 41 42 128) p)
+          (write-bytevector (bytevector 140 240 255) p)
+          (close-output-port p)
+          (get-output-bytevector p))))
+
 (test-end "r7rs tests")
 
 (test-exit)
[ permalink | raw ]

bytevector ports for r7rs egg added by sethlves on Tue Apr 1 19:43:02 2014

Index: scheme.base.scm
===================================================================
--- scheme.base.scm	(revision 30632)
+++ scheme.base.scm	(working copy)
@@ -23,6 +23,8 @@
                 (make-u8vector make-bytevector)
                 (write-u8vector write-bytevector)))
 
+(import (only ports make-input-port make-output-port))
+
 (%include "scheme.base-interface.scm")
 
 ;; For syntax definition helpers.
@@ -784,4 +786,27 @@
       ((bv port start end)
        (read-u8vector!/eof (fx- end start) bv port start)))))
 
+(define (open-input-bytevector bv)
+  (let ((index 0)
+        (bv-len (bytevector-length bv)))
+    (make-input-port
+     (lambda () ; read-char
+       (cond ((= index bv-len) (eof-object))
+             (else
+              (let ((c (bytevector-u8-ref bv index)))
+                (set! index (+ index 1))
+                (integer->char c)))))
+     (lambda () ; char-ready?
+       (not (= index bv-len)))
+     (lambda () #t) ; close
+     (lambda () ; peek-char
+       (if (= index bv-len)
+           (eof-object)
+           (bytevector-u8-ref bv index))))))
+
+(define (open-output-bytevector) (open-output-string))
+
+(define (get-output-bytevector p)
+  (string->utf8 (get-output-string p)))
+
 )
Index: tests/run.scm
===================================================================
--- tests/run.scm	(revision 30632)
+++ tests/run.scm	(working copy)
@@ -973,6 +973,21 @@
                  (import (scheme base))
                  (begin (eq? numbers#+ +)))))
 
+
+(test-group "open-input-bytevector"
+  (test (bytevector 0 1 2 10 13 40 41 42 128 140 240 255)
+        (let ((bv (bytevector 0 1 2 10 13 40 41 42 128 140 240 255)))
+          (read-bytevector 12 (open-input-bytevector bv)))))
+
+(test-group "open-output-bytevector"
+  (test (bytevector 0 1 2 10 13 40 41 42 128 140 240 255)
+        (let ((p (open-output-bytevector)))
+          (write-bytevector (bytevector 0 1 2 10 13) p)
+          (write-bytevector (bytevector 40 41 42 128) p)
+          (write-bytevector (bytevector 140 240 255) p)
+          (close-output-port p)
+          (get-output-bytevector p))))
+
 (test-end "r7rs tests")
 
 (test-exit)
Index: scheme.base-interface.scm
===================================================================
--- scheme.base-interface.scm	(revision 30632)
+++ scheme.base-interface.scm	(working copy)
@@ -58,9 +58,7 @@
   flush-output-port
   for-each
   gcd lcm
-  #|
   get-output-bytevector
-  |#
   get-output-string
   guard
   if
@@ -96,9 +94,7 @@
   null?
   number->string string->number
   number?
-  #|
   open-input-bytevector open-output-bytevector
-  |#
   open-input-string open-output-string
   or
   pair?
[ permalink | raw ]