From 989bf7e1362970df513333305581d29e8cddbd70 Mon Sep 17 00:00:00 2001
From: rtoy <rtoy>
Date: Wed, 31 Oct 2007 14:37:38 +0000
Subject: [PATCH] Update from Paul Foley.

o Disable package errors when loading up external formats.
o A minor patch allowing string-to-octets and vice versa to write into
  a preallocated array (though they might still allocate a bigger one
  if necessary),
o Fix up any confusion between simple-base-string and simple-string so
  that nothing breaks when/if they're not the same.
---
 code/extfmts.lisp | 42 +++++++++++++++++++++++-------------------
 1 file changed, 23 insertions(+), 19 deletions(-)

diff --git a/code/extfmts.lisp b/code/extfmts.lisp
index 5c23b9c11..286dde52e 100644
--- a/code/extfmts.lisp
+++ b/code/extfmts.lisp
@@ -5,7 +5,7 @@
 ;;; domain.
 ;;; 
 (ext:file-comment
- "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/extfmts.lisp,v 1.1 2007/10/25 15:17:07 rtoy Exp $")
+ "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/extfmts.lisp,v 1.2 2007/10/31 14:37:38 rtoy Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -112,8 +112,10 @@
     (setq name tmp))
 
   (or (gethash name *external-formats*)
-      (and (let ((*package* (find-package "STREAM")))
-             (load (format nil "library:ext-formats/~(~A~)" name) :if-does-not-exist nil))
+      (and (let ((*package* (find-package "STREAM"))
+		 (lisp::*enable-package-locked-errors* nil))
+             (load (format nil "library:ext-formats/~(~A~)" name)
+		   :if-does-not-exist nil))
            (gethash name *external-formats*))
       (if error-p (error "External format ~S not found." name) nil)))
 
@@ -169,13 +171,16 @@
 (defmacro char-to-octets (external-format char state output)
   `(codepoint-to-octets ,external-format (char-code ,char) ,state ,output))
 
-(defun string-to-octets (string &key (start 0) end (external-format :default))
+(defun string-to-octets (string &key (start 0) end (external-format :default)
+				     (buffer nil bufferp))
   (declare (type string string)
            (type lisp::index start)
            (type (or null lisp::index) end)
+	   (type (or null (simple-array (unsigned-byte 8) (*))) buffer)
 	   #|(optimize (speed 3) (safety 0) (space 0) (debug 0))|#)
   (let ((ef (find-external-format external-format))
-        (buffer (make-array (length string) :element-type '(unsigned-byte 8)))
+        (buffer (or buffer (make-array (length string)
+				       :element-type '(unsigned-byte 8))))
         (ptr 0)
         (state nil))
     (declare (type external-format ef)
@@ -188,34 +193,36 @@
       (dotimes (i (- (or end (length string)) start))
         (declare (type lisp::index i))
         (char-to-octets ef (char string (+ start i)) state #'out))
-      (lisp::shrink-vector buffer ptr))))
+      (values (if bufferp buffer (lisp::shrink-vector buffer ptr)) ptr))))
 
-(defun octets-to-string (octets &key (start 0) end (external-format :default))
+(defun octets-to-string (octets &key (start 0) end (external-format :default)
+				     (string nil stringp))
   (declare (type (simple-array (unsigned-byte 8) (*)) octets)
            (type lisp::index start)
            (type (or null lisp::index) end)
+	   (type (or null simple-string string))
 	   #|(optimize (speed 3) (safety 0) (space 0) (debug 0))|#)
   (let ((ef (find-external-format external-format))
         (end (1- (or end (length octets))))
-        (string (make-string (length octets)))
+        (string (or string (make-string (length octets))))
         (ptr (1- start))
-        (pos -1)
+        (pos 0)
         (count 0)
         (state nil))
     (declare (type external-format ef)
 	     (type lisp::index end count)
 	     (type (integer -1 (#.array-dimension-limit)) pos ptr)
-	     (type simple-base-string string))
+	     (type simple-string string))
     (flet ((input ()
              (aref octets (incf ptr)))
            (unput (n)
              (decf ptr (the lisp::index n))))
       (loop until (>= ptr end)
-	    ;; increasing size of string shouldn't ever be necessary, unless
-	    ;; someone implements an encoding smaller than the source string...
-            do (setf (schar string (incf pos))
+            do (when (= pos (length string))
+		 (setq string (adjust-array string (* 2 pos))))
+	       (setf (schar string (1- (incf pos)))
 		   (octets-to-char ef state count #'input #'unput))))
-    (lisp::shrink-vector string (1+ pos))))
+    (values (if stringp string (lisp::shrink-vector string pos)) pos)))
 
 
 
@@ -225,7 +232,7 @@
            (type (or null lisp::index) end)
 	   #|(optimize (speed 3) (safety 0) (space 0) (debug 0))|#)
   (let ((ef (find-external-format external-format))
-        (result (make-string (length string)))
+        (result (make-string (length string) :element-type 'base-char))
         (ptr 0)
         (state nil))
     (declare (type external-format ef)
@@ -255,7 +262,7 @@
     (declare (type external-format ef)
 	     (type lisp::index end count)
 	     (type (integer -1 (#.array-dimension-limit)) pos ptr)
-	     (type simple-base-string result))
+	     (type simple-string result))
     (flet ((input ()
              (char-code (char string (incf ptr))))
            (unput (n)
@@ -266,6 +273,3 @@
             do (setf (schar result (incf pos))
 		   (octets-to-char ef state count #'input #'unput))))
     (lisp::shrink-vector result (1+ pos))))
-
-
-(provide :external-formats)
-- 
GitLab