From: Chris Hanson Date: Sun, 8 Jan 2017 21:47:23 +0000 (-0800) Subject: Eliminate all runtime support for external strings. X-Git-Tag: mit-scheme-pucked-9.2.12~227^2~174 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=f82acf441a960a61c9522bfe9481ce20fde9c45f;p=mit-scheme.git Eliminate all runtime support for external strings. --- diff --git a/src/imail/imail-util.scm b/src/imail/imail-util.scm index 077536886..ca9ba4f42 100644 --- a/src/imail/imail-util.scm +++ b/src/imail/imail-util.scm @@ -426,7 +426,7 @@ USA. (call-with-binary-input-file pathname (lambda (port) (let ((n-bytes ((port/operation port 'LENGTH) port))) - (let ((xstring (allocate-external-string n-bytes))) + (let ((xstring (make-string n-bytes))) (let loop ((start 0)) (if (< start n-bytes) (let ((n-read (read-substring! xstring 0 n-bytes port))) @@ -443,7 +443,7 @@ USA. value))) (define (open-xstring-input-port xstring position) - (if (not (<= 0 position (external-string-length xstring))) + (if (not (<= 0 position (string-length xstring))) (error:bad-range-argument position 'OPEN-XSTRING-INPUT-PORT)) (let ((state (make-istate xstring position position position))) (read-xstring-buffer state) @@ -468,7 +468,7 @@ USA. (define (read-xstring-buffer state) (let ((xstring (istate-xstring state)) (start (istate-position state))) - (let ((xend (external-string-length xstring))) + (let ((xend (string-length xstring))) (and (< start xend) (let* ((buffer (istate-buffer state)) (end (min (+ start (string-length buffer)) xend))) @@ -563,7 +563,7 @@ USA. ,(lambda (port) (let ((state (port/state port))) (>= (istate-position state) - (external-string-length (istate-xstring state)))))) + (string-length (istate-xstring state)))))) (CLOSE ,(lambda (port) (let ((state (port/state port))) diff --git a/src/runtime/genio.scm b/src/runtime/genio.scm index fbd060dd0..83f8b0940 100644 --- a/src/runtime/genio.scm +++ b/src/runtime/genio.scm @@ -918,25 +918,6 @@ USA. ((WOULD-BLOCK) #f) ((EOF) 0) (else (error "Unknown result:" r))))))))) - ((external-string? string) - (if (input-buffer-in-8-bit-mode? ib) - (let ((bv (input-buffer-bytes ib)) - (bs (input-buffer-start ib)) - (be (input-buffer-end ib))) - (if (fix:< bs be) - (let ((n (min (fix:- be bs) (- end start)))) - (let ((be (fix:+ bs n))) - (xsubstring-move! bv bs be string start) - (set-input-buffer-prev! ib be) - (set-input-buffer-start! ib be) - n)) - ((source/read (input-buffer-source ib)) string start end))) - (let ((bounce (make-string page-size)) - (be (min page-size (- end start)))) - (let ((n (read-to-8-bit ib bounce 0 be))) - (if (and n (fix:> n 0)) - (xsubstring-move! bounce 0 n string start)) - n)))) (else (error:not-string string 'INPUT-PORT/READ-SUBSTRING!)))) @@ -1103,22 +1084,6 @@ USA. ((fix:> n 0) (loop i)) (else (fix:- i start))))) (fix:- end start))))) - ((external-string? string) - (let ((bounce (make-string #x1000))) - (let loop ((i start)) - (if (< i end) - (let ((n (min (- end i) #x1000))) - (xsubstring-move! string i (+ i n) bounce 0) - (let ((m (write-substring ob bounce 0 n))) - (cond ((not m) - (and (> i start) - (- i start))) - ((fix:> m 0) - (if (fix:< m n) - (- (+ i m) start) - (loop (+ i n)))) - (else (- i start))))) - (- end start))))) (else (error:not-string string 'OUTPUT-PORT/WRITE-SUBSTRING)))) diff --git a/src/runtime/io.scm b/src/runtime/io.scm index 69703ba36..00c93482f 100644 --- a/src/runtime/io.scm +++ b/src/runtime/io.scm @@ -184,9 +184,7 @@ USA. (lambda () ((ucode-primitive channel-read 4) (channel-descriptor channel) - (if (external-string? buffer) - (external-string-descriptor buffer) - buffer) + buffer start end)))) (declare (integrate-operator do-read)) @@ -214,9 +212,7 @@ USA. (lambda () ((ucode-primitive channel-write 4) (channel-descriptor channel) - (if (external-string? buffer) - (external-string-descriptor buffer) - buffer) + buffer start end)))) (declare (integrate-operator do-write)) diff --git a/src/runtime/make.scm b/src/runtime/make.scm index 7fde57117..99bc39596 100644 --- a/src/runtime/make.scm +++ b/src/runtime/make.scm @@ -376,8 +376,7 @@ USA. ("prop1d" . (RUNTIME 1D-PROPERTY)) ("events" . (RUNTIME EVENT-DISTRIBUTOR)) ("gdatab" . (RUNTIME GLOBAL-DATABASE)) - ("gcfinal" . (RUNTIME GC-FINALIZER)) - ("string" . (RUNTIME STRING)))) + ("gcfinal" . (RUNTIME GC-FINALIZER)))) (load-files (lambda (files) (do ((files files (cdr files))) @@ -401,7 +400,6 @@ USA. (package-initialize '(RUNTIME POPULATION) 'INITIALIZE-UNPARSER! #t) (package-initialize '(RUNTIME 1D-PROPERTY) 'INITIALIZE-UNPARSER! #t) (package-initialize '(RUNTIME GC-FINALIZER) #f #t) - (package-initialize '(RUNTIME STRING) #f #t) ;First GC-finalizer (set! boot-defs (package/environment (name->package '(RUNTIME BOOT-DEFINITIONS)))) diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg index dd3d8e855..1eb46e7e7 100644 --- a/src/runtime/runtime.pkg +++ b/src/runtime/runtime.pkg @@ -955,7 +955,6 @@ USA. (vector-8b-length string-length) (vector-8b-maximum-length string-maximum-length) (vector-8b? string?) - allocate-external-string ascii-string-copy burst-string camel-case-string->lisp @@ -963,9 +962,6 @@ USA. decorated-string-append error:not-string error:not-xstring - external-string-descriptor - external-string-length - external-string? guarantee-string guarantee-string-index guarantee-substring diff --git a/src/runtime/string.scm b/src/runtime/string.scm index ec5300994..27ee28752 100644 --- a/src/runtime/string.scm +++ b/src/runtime/string.scm @@ -1642,103 +1642,45 @@ USA. (outer k (fix:+ q 1))))) pi)) -;;;; External Strings - -(define external-strings) -(define (initialize-package!) - (set! external-strings - (make-gc-finalizer (ucode-primitive deallocate-external-string) - external-string? - external-string-descriptor - set-external-string-descriptor!)) - unspecific) - -(define-structure external-string - descriptor - (length #f read-only #t)) - -(define (allocate-external-string n-bytes) - (without-interruption - (lambda () - (add-to-gc-finalizer! - external-strings - (make-external-string - ((ucode-primitive allocate-external-string) n-bytes) - n-bytes))))) - -(define-integrable (external-string-ref string index) - (ascii->char - (external-string-byte-ref string index))) - -(define-integrable (external-string-byte-ref string index) - ((ucode-primitive read-byte-from-memory) - (+ (external-string-descriptor string) index))) - -(define-integrable (external-string-set! string index char) - (external-string-byte-set! string index (char->ascii char))) - -(define-integrable (external-string-byte-set! string index byte) - ((ucode-primitive write-byte-to-memory) - byte - (+ (external-string-descriptor string) index))) - -(define-integrable (external-substring-fill! string start end char) - ((ucode-primitive VECTOR-8B-FILL!) (external-string-descriptor string) - start - end - (char->ascii char))) - (define (xstring? object) (or (string? object) - (wide-string? object) - (external-string? object))) + (wide-string? object))) (define (xstring-length string) (cond ((string? string) (string-length string)) ((wide-string? string) (wide-string-length string)) - ((external-string? string) (external-string-length string)) (else (error:not-xstring string 'XSTRING-LENGTH)))) (define (xstring-ref string index) (cond ((string? string) (string-ref string index)) ((wide-string? string) (wide-string-ref string index)) - ((external-string? string) (external-string-ref string index)) (else (error:not-xstring string 'XSTRING-REF)))) (define (xstring-byte-ref string index) (cond ((string? string) (vector-8b-ref string index)) ((wide-string? string) (wide-string-ref string index)) - ((external-string? string) (external-string-byte-ref string index)) (else (error:not-xstring string 'XSTRING-BYTE-REF)))) (define (xstring-set! string index char) (cond ((string? string) (string-set! string index char)) ((wide-string? string) (wide-string-set! string index char)) - ((external-string? string) (external-string-set! string index char)) (else (error:not-xstring string 'XSTRING-SET!)))) (define (xstring-byte-set! string index byte) (cond ((string? string) (vector-8b-set! string index byte)) ((wide-string? string) (wide-string-set! string index byte)) - ((external-string? string) - (external-string-byte-set! string index byte)) (else (error:not-xstring string 'XSTRING-BYTE-SET!)))) (define (xstring-move! xstring1 xstring2 start2) (xsubstring-move! xstring1 0 (xstring-length xstring1) xstring2 start2)) (define (xsubstring-move! xstring1 start1 end1 xstring2 start2) - (let ((deref - (lambda (xstring) - (if (external-string? xstring) - (external-string-descriptor xstring) - xstring)))) - (cond ((or (not (eq? xstring2 xstring1)) (< start2 start1)) - (substring-move-left! (deref xstring1) start1 end1 - (deref xstring2) start2)) - ((> start2 start1) - (substring-move-right! (deref xstring1) start1 end1 - (deref xstring2) start2))))) + (cond ((or (not (eq? xstring2 xstring1)) (< start2 start1)) + (substring-move-left! xstring1 start1 end1 + xstring2 start2)) + ((> start2 start1) + (substring-move-right! xstring1 start1 end1 + xstring2 start2)))) (define (xsubstring xstring start end) (guarantee-xsubstring xstring start end 'XSUBSTRING) @@ -1749,19 +1691,12 @@ USA. (define (xstring-fill! xstring char) (cond ((string? xstring) (string-fill! xstring char)) - ((external-string? xstring) - (external-substring-fill! xstring - 0 - (external-string-length xstring) - char)) (else (error:not-xstring xstring 'XSTRING-FILL!)))) (define (xsubstring-fill! xstring start end char) (cond ((string? xstring) (substring-fill! xstring start end char)) - ((external-string? xstring) - (external-substring-fill! xstring start end char)) (else (error:not-xstring xstring 'XSTRING-FILL!)))) @@ -1769,9 +1704,6 @@ USA. (cond ((string? xstring) (guarantee-substring xstring start end caller) (finder xstring start end datum)) - ((external-string? xstring) - (guarantee-xsubstring xstring start end caller) - (finder (external-string-descriptor xstring) start end datum)) (else (error:not-xstring xstring caller)))) diff --git a/src/runtime/stringio.scm b/src/runtime/stringio.scm index b4130777e..12a3e846b 100644 --- a/src/runtime/stringio.scm +++ b/src/runtime/stringio.scm @@ -51,12 +51,6 @@ USA. 'OPEN-INPUT-STRING) (make-port wide-input-type (make-internal-input-state string start end)))) - ((external-string? string) - (receive (start end) - (check-index-limits start end (xstring-length string) - 'OPEN-INPUT-STRING) - (make-port external-input-type - (make-external-input-state string start end)))) (else (error:not-string string 'OPEN-INPUT-STRING)))) @@ -173,55 +167,6 @@ USA. (error "Unread char incorrect:" char)) (set-iistate-next! ss prev)))) -(define (make-external-input-type) - (make-port-type - `((CHAR-READY? ,string-in/char-ready?) - (EOF? ,external-in/eof?) - (PEEK-CHAR ,external-in/peek-char) - (READ-CHAR ,external-in/read-char) - (READ-SUBSTRING ,external-in/read-substring) - (UNREAD-CHAR ,external-in/unread-char) - (WRITE-SELF ,string-in/write-self)) - #f)) - -(define (make-external-input-state string start end) - (make-xistate (external-string-source string start end) #f #f)) - -(define-structure xistate - (source #f read-only #t) - unread) - -(define (external-in/eof? port) - (let ((xs (port/%state port))) - (and (not (xistate-unread xs)) - (not ((xistate-source xs)))))) - -(define (external-in/peek-char port) - (let ((xs (port/%state port))) - (or (xistate-unread xs) - (let ((char ((xistate-source xs)))) - (set-xistate-unread! xs char) - char)))) - -(define (external-in/read-char port) - (let ((xs (port/%state port))) - (let ((unread (xistate-unread xs))) - (if unread - (begin - (set-xistate-unread! xs #f) - unread) - ((xistate-source xs)))))) - -(define (external-in/unread-char port char) - (let ((xs (port/%state port))) - (if (xistate-unread xs) - (error "Can't unread two chars.")) - (set-xistate-unread! xs char))) - -(define (external-in/read-substring port string start end) - (source->sink! (xistate-source (port/%state port)) - (string-sink string start end))) - (define (move-chars! string start end string* start* end*) (let ((n (min (- end start) (- end* start*)))) (let ((end (+ start n)) @@ -245,13 +190,11 @@ USA. (define (string-source string start end) (cond ((string? string) (narrow-string-source string start end)) ((wide-string? string) (wide-string-source string start end)) - ((external-string? string) (external-string-source string start end)) (else (error:not-string string #f)))) (define (string-sink string start end) (cond ((string? string) (narrow-string-sink string start end)) ((wide-string? string) (wide-string-sink string start end)) - ((external-string? string) (external-string-sink string start end)) (else (error:not-string string #f)))) (define (narrow-string-source string start end) @@ -289,46 +232,6 @@ USA. (set! start (+ start 1)) #t)))) -(define (external-string-source string start end) - (let ((buffer (make-string #x1000)) - (bi #x1000) - (next start)) - (lambda () - (and (< next end) - (begin - (if (fix:>= bi #x1000) - (begin - (xsubstring-move! string next (min (+ next #x1000) end) - buffer 0) - (set! bi 0))) - (let ((char (string-ref buffer bi))) - (set! bi (fix:+ bi 1)) - (set! next (+ next 1)) - char)))))) - -(define (external-string-sink string start end) - (let ((buffer (make-string #x1000)) - (bi 0)) - (lambda (char) - (if char - (begin - (if (not (fix:< (char->integer char) #x100)) - (error:not-8-bit-char char)) - (and (< start end) - (begin - (string-set! buffer bi char) - (set! bi (fix:+ bi 1)) - (set! start (+ start 1)) - (if (fix:= bi #x1000) - (begin - (xsubstring-move! buffer 0 bi string (- start bi)) - (set! bi 0))) - #t))) - (begin - (xsubstring-move! buffer 0 bi string (- start bi)) - (set! bi 0) - #f))))) - ;;;; Input as byte vector (define (call-with-input-octets octets procedure) @@ -620,7 +523,6 @@ USA. (define narrow-input-type) (define wide-input-type) -(define external-input-type) (define octets-input-type) (define narrow-output-type) (define wide-output-type) @@ -630,7 +532,6 @@ USA. (define (initialize-package!) (set! narrow-input-type (make-narrow-input-type)) (set! wide-input-type (make-wide-input-type)) - (set! external-input-type (make-external-input-type)) (set! octets-input-type (make-octets-input-type)) (set! narrow-output-type (make-narrow-output-type)) (set! wide-output-type (make-wide-output-type))