big strings

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