On 19D the following code will cause an error:
* (defun test-string-stream ()
(with-output-to-string (stream)
(dotimes (x 17)
(write-string (make-string (* 1024 1024)) stream)))
(values))
TEST-STRING-STREAM
* (test-string-stream)
; [GC threshold exceeded with 18,887,688 bytes in use. Commencing GC.]
; [GC completed with 13,461,936 bytes retained and 5,425,752 bytes freed.]
; [GC will next occur when at least 25,461,936 bytes are in use.]
; [GC threshold exceeded with 33,388,360 bytes in use. Commencing GC.]
; [GC completed with 33,390,368 bytes retained and -2,008 bytes freed.]
; [GC will next occur when at least 45,390,368 bytes are in use.]
; [GC threshold exceeded with 74,288,928 bytes in use. Commencing GC.]
; [GC completed with 54,362,504 bytes retained and 19,926,424 bytes freed.]
; [GC will next occur when at least 66,362,504 bytes are in use.]
Type-error in KERNEL::OBJECT-NOT-TYPE-ERROR-HANDLER:
134217792 is not of type (UNSIGNED-BYTE 27)
[Condition of type TYPE-ERROR]
Restarts:
0: [ABORT] Return to Top-Level.
Debug (type H for help)
(KERNEL:BIT-BASH-COPY 5
""
64
""
...)[:EXTERNAL]
Source: Error finding source:
Error in function DEBUG::GET-FILE-TOP-LEVEL-FORM: Source file no longer exists:
target:code/bit-bash.lisp.
0]
----------------------------------------------------------------------
Note that the error is signaled starting from 17MB.
The following code gets rid of the bug in the string streams, although
there may be a more serious error somewhere else, as I haven't been
able to track down the call to BIT-BASH-COPY.
(in-package :lisp)
(defun my-string-sout (stream string start end)
(declare (simple-string string) (fixnum start end))
(let* ((current (string-output-stream-index stream))
(length (- end start))
(dst-end (+ length current))
(workspace (string-output-stream-string stream)))
(declare (simple-string workspace)
(fixnum current length))
(unless (< dst-end (length workspace))
(let ((new-length (min (1- array-dimension-limit)
(+ (* current 2) length))))
(unless (<= dst-end new-length)
(error "Can't stretch output string any further."))
(let ((new-workspace (make-string new-length)))
(do ((i 0 (1+ i)))
((= i current))
(declare (fixnum i))
(setf (aref new-workspace i)
(aref workspace i)))
(setf workspace new-workspace
(string-output-stream-string stream) new-workspace))))
(do ((target-index current (1+ target-index))
(source-index start (1+ source-index)))
((or (= target-index dst-end)
(= source-index end)))
(declare (fixnum target-index source-index))
(setf (aref workspace target-index)
(aref string source-index)))
(setf (string-output-stream-index stream) dst-end)))
(defstruct (string-output-stream
(:include string-stream
(out #'string-ouch)
(sout #'my-string-sout)
(misc #'string-out-misc))
(:print-function %print-string-output-stream)
(:constructor %make-string-output-stream ()))
;; The string we throw stuff in.
(string (make-string 40) :type simple-string)
;; Index of the next location to use.
(index 0 :type fixnum))
(defun get-output-stream-string (stream)
"Returns a string of all the characters sent to a stream made by
Make-String-Output-Stream since the last call to this function."
(declare (type string-output-stream stream))
(let* ((length (string-output-stream-index stream))
(result (make-string length))
(source (string-output-stream-string stream)))
(do ((i 0 (1+ i)))
((= i length))
(declare (fixnum i))
(setf (aref result i)
(aref source i)))
(setf (string-output-stream-index stream) 0)
result))
--
walter pelissero
http://www.pelissero.de
