(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)))
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)
(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)))
,(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)))
((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!))))
\f
((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))))
\f
(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))
(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))
("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)))
(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))))
(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
decorated-string-append
error:not-string
error:not-xstring
- external-string-descriptor
- external-string-length
- external-string?
guarantee-string
guarantee-string-index
guarantee-substring
(outer k (fix:+ q 1)))))
pi))
\f
-;;;; 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)))
-\f
(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)
(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!))))
(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))))
'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))))
(error "Unread char incorrect:" char))
(set-iistate-next! ss prev))))
\f
-(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)))
-\f
(define (move-chars! string start end string* start* end*)
(let ((n (min (- end start) (- end* start*))))
(let ((end (+ start n))
(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)
(set! start (+ start 1))
#t))))
\f
-(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)))))
-\f
;;;; Input as byte vector
(define (call-with-input-octets octets procedure)
\f
(define narrow-input-type)
(define wide-input-type)
-(define external-input-type)
(define octets-input-type)
(define narrow-output-type)
(define wide-output-type)
(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))
projects / mit-scheme.git / commitdiff