Undo genio hack: external-string buffers.

diff --git a/src/gtk/gio.scm b/src/gtk/gio.scm
index 5554a9472b0473acfcf4655fa827d0f649ec04c5..c4d5cf6db19622db33adfb51ffa617bb341d2843 100644 (file)
--- a/src/gtk/gio.scm
+++ b/src/gtk/gio.scm
@@ -27,8 +27,7 @@ USA.
 (define (open-input-gfile uri)
   (let* ((gfile (make-gfile uri))
         (gstream (gfile-read gfile))
-        (port (fluid-let ((allocate-buffer-bytes allocate-external-string))
-                (make-generic-i/o-port (make-g-stream-source gstream) #f))))
+        (port (make-generic-i/o-port (make-g-stream-source gstream) #f)))
     ;;(port/set-coding port 'ISO-8859-1)
     ;;(port/set-line-ending port 'NEWLINE)
     port))
@@ -59,8 +58,7 @@ USA.
 (define (open-output-gfile uri)
   (let* ((gfile (make-gfile uri))
         (gstream (gfile-replace gfile #f #t 'private))
-        (port (fluid-let ((allocate-buffer-bytes allocate-external-string))
-                (make-generic-i/o-port #f (make-g-stream-sink gstream)))))
+        (port (make-generic-i/o-port #f (make-g-stream-sink gstream))))
     ;;(port/set-coding port 'ISO-8859-1)
     ;;(port/set-line-ending port 'NEWLINE)
     port))
@@ -94,7 +92,15 @@ USA.
    define standard initial-value 10)
 
   (queue
-   define accessor initializer (lambda () (make-thread-queue 1))))
+   define accessor initializer (lambda () (make-thread-queue 1)))
+
+  (buffer
+   define standard initializer (lambda () (malloc buffer-size 'uchar)))
+
+  (buffer-size
+   define standard initializer (lambda () buffer-size)))
+
+(define buffer-size #x1000)
 
 ;;; When these streams are GCed, any pending operation must be
 ;;; cancelled.  This ensures that the operation's finish callback will
@@ -127,8 +133,9 @@ USA.
   ;; To avoid registering read or skip finish callbacks for every read
   ;; or skip (a LOT of registering/deregistering!), the open operation
   ;; (i.e. gfile-read) registers them in advance.
-  read-id
-  skip-id)
+  read-id                ; #f or the read finish callback ID
+  skip-id                ; #f or the skip finish callback ID
+  )
 
 (define-method initialize-instance ((object <g-input-stream>))
   (call-next-method object)
@@ -186,8 +193,7 @@ USA.
     (if (g-input-stream-cancel-info-pending-op info)
        (error "Operation pending:" gstream))
     (let* ((count (fix:- end start))
-          (async-buffer (alien-byte-increment! (external-string->alien buffer)
-                                               start)))
+          (async-buffer (ensure-buffer gstream count)))
       (set-g-input-stream-cancel-info-pending-op! info 'READ)
       (C-call "g_input_stream_read_async"
              (gobject-alien gstream)
@@ -204,9 +210,22 @@ USA.
              (set-g-input-stream-cancel-info-pending-op! info 'ERROR)
              (error "Error reading:" gstream value))
            (begin
+             (c-peek-bytes async-buffer 0 value buffer start)
              (set-g-input-stream-cancel-info-pending-op! info #f)
              value))))))
 
+(define-integrable (ensure-buffer gstream count)
+  (let ((size (g-stream-buffer-size gstream))
+       (buffer (g-stream-buffer gstream)))
+    (if (fix:< size count)
+       (begin
+         (free buffer)
+         (let ((buffer* (malloc count 'uchar)))
+           (set-g-stream-buffer! gstream buffer*)
+           (set-g-stream-buffer-size! gstream count)
+           buffer*))
+       buffer)))
+
 (define (make-g-input-stream-read-finish-callback queue gerror*)
   (C-callback
    (named-lambda (g-input-stream-read-finish-callback source result)
@@ -372,9 +391,9 @@ USA.
     (if (g-output-stream-cancel-info-pending-op info)
        (error "Operation pending:" gstream))
     (let* ((count (fix:- end start))
-          (async-buffer (alien-byte-increment! (external-string->alien buffer)
-                                               start)))
+          (async-buffer (ensure-buffer gstream count)))
       (set-g-output-stream-cancel-info-pending-op! info 'WRITE)
+      (c-poke-bytes async-buffer 0 count buffer start)
       (C-call "g_output_stream_write_async"
              (gobject-alien gstream)
              async-buffer
@@ -661,11 +680,6 @@ USA.
       (begin
        (%trace ";g-output-stream-"op"-callback "alien" "queue"\n")
        (%queue! queue alien))))
-
-(define-integrable (external-string->alien xstr)
-  (let ((alien (make-alien 'uchar)))
-    (%set-alien/address! alien (external-string-descriptor xstr))
-    alien))
 \f
 (define-class (<gfile> (constructor (uri)))
     (<gobject>)

diff --git a/src/gtk/gtk.pkg b/src/gtk/gtk.pkg
index 2aeb837f0bb7b1dfdbafbbd2c673d0e8a9ab4fe5..90b9e98eea5a6c1546df0fadeaa37d85f58cc1d3 100644 (file)
--- a/src/gtk/gtk.pkg
+++ b/src/gtk/gtk.pkg
@@ -64,8 +64,7 @@ USA.
          %set-alien/address!)
   (import (runtime generic-i/o-port)
          make-gsource
-         make-gsink
-         allocate-buffer-bytes)
+         make-gsink)
   (import (gtk main)
          maybe-yield-gtk)
   (export (gtk)

diff --git a/src/runtime/genio.scm b/src/runtime/genio.scm
index aabcba4d8d8c8e8a6d0ba4ddc5b642aac209ee4f..6a3b6cfa40fb3388565370be98d8d41958cbb871 100644 (file)
--- a/src/runtime/genio.scm
+++ b/src/runtime/genio.scm
@@ -28,7 +28,7 @@ USA.
 ;;; package: (runtime generic-i/o-port)
 
 (declare (usual-integrations)
-        (integrate-external "port" "string"))
+        (integrate-external "port"))
 \f
 (define (make-generic-i/o-port source sink #!optional type . extra-state)
   (if (not (or source sink))
@@ -719,8 +719,6 @@ USA.
   (fix:+ page-size
         (fix:- (fix:* max-char-bytes 4) 1)))
 
-(define allocate-buffer-bytes make-string)
-
 (define-structure (input-buffer (constructor %make-input-buffer))
   (source #f read-only #t)
   (bytes #f read-only #t)
@@ -734,7 +732,7 @@ USA.
 
 (define (make-input-buffer source coder-name normalizer-name)
   (%make-input-buffer source
-                     (allocate-buffer-bytes byte-buffer-length)
+                     (make-string byte-buffer-length)
                      byte-buffer-length
                      byte-buffer-length
                      byte-buffer-length
@@ -809,15 +807,15 @@ USA.
   (eq? (input-buffer-normalize ib) binary-normalizer))
 
 (define (input-buffer-contents ib)
-  (xsubstring (input-buffer-bytes ib)
-             (input-buffer-start ib)
-             (input-buffer-end ib)))
+  (substring (input-buffer-bytes ib)
+            (input-buffer-start ib)
+            (input-buffer-end ib)))
 
 (define (set-input-buffer-contents! ib contents)
   (guarantee-string contents 'SET-INPUT-BUFFER-CONTENTS!)
   (let ((bv (input-buffer-bytes ib)))
-    (let ((n (fix:min (string-length contents) (xstring-length bv))))
-      (xsubstring-move! contents 0 n bv 0)
+    (let ((n (fix:min (string-length contents) (string-length bv))))
+      (substring-move! contents 0 n bv 0)
       (set-input-buffer-prev! ib 0)
       (set-input-buffer-start! ib 0)
       (set-input-buffer-end! ib n))))
@@ -858,7 +856,7 @@ USA.
     (let ((do-read
           (lambda (be)
             (let ((be* (fix:+ be page-size)))
-              (if (not (fix:<= be* (xstring-length bv)))
+              (if (not (fix:<= be* (vector-8b-length bv)))
                   (error "Input buffer overflow:" ib))
               ((source/read (input-buffer-source ib)) bv be be*)))))
       (let ((bs (input-buffer-start ib))
@@ -866,11 +864,13 @@ USA.
        (if (fix:< bs be)
            (begin
              (if (fix:> bs 0)
-                 (begin
-                   (xsubstring-move! bv bs be bv 0)
-                   (set-input-buffer-prev! ib 0)
-                   (set-input-buffer-start! ib 0)
-                   (set-input-buffer-end! ib (fix:- be bs))))
+                 (do ((i bs (fix:+ i 1))
+                      (j 0 (fix:+ j 1)))
+                     ((not (fix:< i be))
+                      (set-input-buffer-prev! ib 0)
+                      (set-input-buffer-start! ib 0)
+                      (set-input-buffer-end! ib j))
+                   (string-set! bv j (string-ref bv i))))
              (let ((be (input-buffer-end ib)))
                (let ((n (do-read be)))
                  (if n
@@ -894,7 +894,7 @@ USA.
               (if (fix:< bs be)
                   (let ((n (fix:min (fix:- be bs) (fix:- end start))))
                     (let ((be (fix:+ bs n)))
-                      (xsubstring-move! bv bs be string start)
+                      (%substring-move! bv bs be string start)
                       (set-input-buffer-prev! ib be)
                       (set-input-buffer-start! ib be)
                       n))
@@ -979,7 +979,7 @@ USA.
 
 (define (make-output-buffer sink coder-name normalizer-name)
   (%make-output-buffer sink
-                      (allocate-buffer-bytes byte-buffer-length)
+                      (make-string byte-buffer-length)
                       0
                       0
                       (name->encoder coder-name)
@@ -1010,7 +1010,7 @@ USA.
   ((sink/get-port (output-buffer-sink ob))))
 
 (define-integrable (output-buffer-end ob)
-  (xstring-length (output-buffer-bytes ob)))
+  (string-length (output-buffer-bytes ob)))
 
 (define (flush-output-buffer buffer)
   (set-output-buffer-start! buffer 0))
@@ -1037,9 +1037,11 @@ USA.
                  0
                  (fix:min bs page-size))))
            (if (and n (fix:> n 0))
-               (begin
-                 (xsubstring-move! bv n bs bv 0)
-                 (set-output-buffer-start! ob (fix:- bs n))))
+               (do ((bi n (fix:+ bi 1))
+                    (bj 0 (fix:+ bj 1)))
+                   ((not (fix:< bi bs))
+                    (set-output-buffer-start! ob bj))
+                 (vector-8b-set! bv bj (vector-8b-ref bv bi))))
            n))
        0)))
 
@@ -1124,8 +1126,7 @@ USA.
 
 (define-decoder 'ISO-8859-1
   (lambda (ib)
-    (let ((cp (xstring-byte-ref (input-buffer-bytes ib)
-                               (input-buffer-start ib))))
+    (let ((cp (vector-8b-ref (input-buffer-bytes ib) (input-buffer-start ib))))
       (set-input-buffer-start! ib (fix:+ (input-buffer-start ib) 1))
       cp)))
 
@@ -1133,7 +1134,7 @@ USA.
   (lambda (ob cp)
     (if (not (fix:< cp #x100))
        (error:char-encoding ob cp))
-    (xstring-byte-set! (output-buffer-bytes ob) (output-buffer-start ob) cp)
+    (vector-8b-set! (output-buffer-bytes ob) (output-buffer-start ob) cp)
     1))
 
 (define-sizer 'ISO-8859-1
@@ -1179,8 +1180,8 @@ USA.
 (define (decode-8-bit ib table)
   (let ((cp
         (vector-ref table
-                    (xstring-byte-ref (input-buffer-bytes ib)
-                                      (input-buffer-start ib)))))
+                    (vector-8b-ref (input-buffer-bytes ib)
+                                   (input-buffer-start ib)))))
     (if cp
        (begin
          (set-input-buffer-start! ib (fix:+ (input-buffer-start ib) 1))
@@ -1188,20 +1189,20 @@ USA.
        (error:char-decoding ib))))
 
 (define (encode-8-bit ob cp start map-lhs map-rhs)
-  (xstring-byte-set! (input-buffer-bytes ob)
-                    (input-buffer-start ob)
-                    (if (fix:< cp start)
-                        cp
-                        (let loop ((low 0) (high (vector-length map-lhs)))
-                          (if (not (fix:< low high))
-                              (error:char-encoding ob cp))
-                          (let ((i (fix:quotient (fix:+ low high) 2)))
-                            (cond ((fix:< cp (vector-ref map-lhs i))
-                                   (loop low i))
-                                  ((fix:> cp (vector-ref map-lhs i))
-                                   (loop (fix:+ i 1) high))
-                                  (else
-                                   (vector-8b-ref map-rhs i)))))))
+  (vector-8b-set! (input-buffer-bytes ob)
+                 (input-buffer-start ob)
+                 (if (fix:< cp start)
+                     cp
+                     (let loop ((low 0) (high (vector-length map-lhs)))
+                       (if (not (fix:< low high))
+                           (error:char-encoding ob cp))
+                       (let ((i (fix:quotient (fix:+ low high) 2)))
+                         (cond ((fix:< cp (vector-ref map-lhs i))
+                                (loop low i))
+                               ((fix:> cp (vector-ref map-lhs i))
+                                (loop (fix:+ i 1) high))
+                               (else
+                                (vector-8b-ref map-rhs i)))))))
   1)
 
 (define (reverse-iso-8859-map start code-points)
@@ -1782,10 +1783,10 @@ USA.
          (else (error:char-encoding ib cp)))))
 
 (define-integrable (get-byte bv base offset)
-  (xstring-byte-ref bv (fix:+ base offset)))
+  (vector-8b-ref bv (fix:+ base offset)))
 
 (define-integrable (put-byte bv base offset byte)
-  (xstring-byte-set! bv (fix:+ base offset) byte))
+  (vector-8b-set! bv (fix:+ base offset) byte))
 
 (define-integrable (extract b m n)
   (fix:lsh (fix:and b m) n))