From: Matt Birkholz <matt@birkholz.chandler.az.us>
Date: Thu, 21 Jul 2011 20:34:29 +0000 (-0700)
Subject: Undo genio hack: external-string buffers.
X-Git-Tag: mit-scheme-pucked-9.2.12~665
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=6910d4e855c5a566ccf0146577c9e92b2ecb14e9;p=mit-scheme.git
Undo genio hack: external-string buffers.
---
diff --git a/src/gtk/gio.scm b/src/gtk/gio.scm
index 5554a9472..c4d5cf6db 100644
--- 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))
(define-class (<gfile> (constructor (uri)))
(<gobject>)
diff --git a/src/gtk/gtk.pkg b/src/gtk/gtk.pkg
index 2aeb837f0..90b9e98ee 100644
--- 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 aabcba4d8..6a3b6cfa4 100644
--- 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"))
(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))