Steel Bank Common Lisp

Update of /cvsroot/sbcl/sbcl
In directory sc8-pr-cvs8.sourceforge.net:/tmp/cvs-serv12235

Modified Files:
	version.lisp-expr 
Log Message:
1.0.6.31: use proper types for STRING-DISPATCH

	* We only want to let one-dimensional character strings through.
	  This change will probably produce better code, too.


Index: version.lisp-expr
===================================================================
RCS file: /cvsroot/sbcl/sbcl/version.lisp-expr,v
retrieving revision 1.3454
retrieving revision 1.3455
diff -u -d -r1.3454 -r1.3455
--- version.lisp-expr	6 Jun 2007 21:12:48 -0000	1.3454
+++ version.lisp-expr	6 Jun 2007 22:28:52 -0000	1.3455
@@ -17,4 +17,4 @@
 ;;; checkins which aren't released. (And occasionally for internal
 ;;; versions, especially for internal versions off the main CVS
 ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"1.0.6.30"
+"1.0.6.31"

Update of /cvsroot/sbcl/sbcl/src/code
In directory sc8-pr-cvs8.sourceforge.net:/tmp/cvs-serv12235/src/code

Modified Files:
	fd-stream.lisp pprint.lisp 
Log Message:
1.0.6.31: use proper types for STRING-DISPATCH

	* We only want to let one-dimensional character strings through.
	  This change will probably produce better code, too.


Index: fd-stream.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/fd-stream.lisp,v
retrieving revision 1.112
retrieving revision 1.113
diff -u -d -r1.112 -r1.113
--- fd-stream.lisp	6 Jun 2007 21:12:48 -0000	1.112
+++ fd-stream.lisp	6 Jun 2007 22:28:53 -0000	1.113
@@ -1111,7 +1111,7 @@
             (setf (fd-stream-obuf-tail stream)
                   (string-dispatch (simple-base-string
                                     #!+sb-unicode
-                                    (simple-array character)
+                                    (simple-array character (*))
                                     string)
                       string
                     (let ((len (fd-stream-obuf-length stream))
@@ -1291,7 +1291,7 @@
             (setf (fd-stream-obuf-tail stream)
                   (string-dispatch (simple-base-string
                                     #!+sb-unicode
-                                    (simple-array character)
+                                    (simple-array character (*))
                                     string)
                       string
                     (let ((len (fd-stream-obuf-length stream))

Index: pprint.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/pprint.lisp,v
retrieving revision 1.35
retrieving revision 1.36
diff -u -d -r1.35 -r1.36
--- pprint.lisp	28 Jun 2006 10:20:07 -0000	1.35
+++ pprint.lisp	6 Jun 2007 22:28:53 -0000	1.36
@@ -138,7 +138,7 @@
     (unless (= start end)
       (sb!impl::string-dispatch (simple-base-string
                                  #!+sb-unicode
-                                 (simple-array character))
+                                 (simple-array character (*)))
           string
         ;; For POSITION transform
         (declare (optimize (speed 2)))

Update of /cvsroot/sbcl/sbcl/src/code
In directory sc8-pr-cvs8.sourceforge.net:/tmp/cvs-serv14175/src/code

Modified Files:
	fd-stream.lisp 
Log Message:
1.0.6.30: clean up FD-SOUT a little bit

	* Apparently the bozos have been dealt with; we now receive strings
	  to all calls to this function;
	* Declare types appropriately.


Index: fd-stream.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/fd-stream.lisp,v
retrieving revision 1.111
retrieving revision 1.112
diff -u -d -r1.111 -r1.112
--- fd-stream.lisp	5 Jun 2007 20:18:43 -0000	1.111
+++ fd-stream.lisp	6 Jun 2007 21:12:48 -0000	1.112
@@ -538,53 +538,40 @@
 ;;; unbuffered, slam the string down the file descriptor, otherwise
 ;;; use OUTPUT-RAW-BYTES to buffer the string. Update charpos by
 ;;; checking to see where the last newline was.
-;;;
-;;; Note: some bozos (the FASL dumper) call write-string with things
-;;; other than strings. Therefore, we must make sure we have a string
-;;; before calling POSITION on it.
-;;; KLUDGE: It would be better to fix the bozos instead of trying to
-;;; cover for them here. -- WHN 20000203
 (defun fd-sout (stream thing start end)
+  (declare (type fd-stream stream) (type string thing))
   (let ((start (or start 0))
         (end (or end (length (the vector thing)))))
     (declare (fixnum start end))
-    (if (stringp thing)
-        (let ((last-newline
-               (string-dispatch (simple-base-string
-                                 #!+sb-unicode
-                                 (simple-array character)
-                                 string)
-                   thing
-                 (position #\newline thing :from-end t
-                           :start start :end end))))
-          (if (and (typep thing 'base-string)
-                   (eq (fd-stream-external-format stream) :latin-1))
-              (ecase (fd-stream-buffering stream)
-                (:full
-                 (output-raw-bytes stream thing start end))
-                (:line
-                 (output-raw-bytes stream thing start end)
-                 (when last-newline
-                   (flush-output-buffer stream)))
-                (:none
-                 (frob-output stream thing start end nil)))
-              (ecase (fd-stream-buffering stream)
-                (:full (funcall (fd-stream-output-bytes stream)
-                                stream thing nil start end))
-                (:line (funcall (fd-stream-output-bytes stream)
-                                stream thing last-newline start end))
-                (:none (funcall (fd-stream-output-bytes stream)
-                                stream thing t start end))))
-          (if last-newline
-              (setf (fd-stream-char-pos stream)
-                    (- end last-newline 1))
-              (incf (fd-stream-char-pos stream)
-                    (- end start))))
-        (ecase (fd-stream-buffering stream)
-          ((:line :full)
-           (output-raw-bytes stream thing start end))
-          (:none
-           (frob-output stream thing start end nil))))))
+    (let ((last-newline
+           (string-dispatch (simple-base-string
+                             #!+sb-unicode
+                             (simple-array character (*))
+                             string)
+               thing
+             (position #\newline thing :from-end t
+                       :start start :end end))))
+      (if (and (typep thing 'base-string)
+               (eq (fd-stream-external-format stream) :latin-1))
+          (ecase (fd-stream-buffering stream)
+            (:full
+             (output-raw-bytes stream thing start end))
+            (:line
+             (output-raw-bytes stream thing start end)
+             (when last-newline
+               (flush-output-buffer stream)))
+            (:none
+             (frob-output stream thing start end nil)))
+          (ecase (fd-stream-buffering stream)
+            (:full (funcall (fd-stream-output-bytes stream)
+                            stream thing nil start end))
+            (:line (funcall (fd-stream-output-bytes stream)
+                            stream thing last-newline start end))
+            (:none (funcall (fd-stream-output-bytes stream)
+                            stream thing t start end))))
+      (if last-newline
+          (setf (fd-stream-char-pos stream) (- end last-newline 1))
+          (incf (fd-stream-char-pos stream) (- end start))))))
 
 (defvar *external-formats* ()
   #!+sb-doc

Update of /cvsroot/sbcl/sbcl
In directory sc8-pr-cvs8.sourceforge.net:/tmp/cvs-serv14175

Modified Files:
	version.lisp-expr 
Log Message:
1.0.6.30: clean up FD-SOUT a little bit

	* Apparently the bozos have been dealt with; we now receive strings
	  to all calls to this function;
	* Declare types appropriately.


Index: version.lisp-expr
===================================================================
RCS file: /cvsroot/sbcl/sbcl/version.lisp-expr,v
retrieving revision 1.3453
retrieving revision 1.3454
diff -u -d -r1.3453 -r1.3454
--- version.lisp-expr	6 Jun 2007 02:23:46 -0000	1.3453
+++ version.lisp-expr	6 Jun 2007 21:12:48 -0000	1.3454
@@ -17,4 +17,4 @@
 ;;; checkins which aren't released. (And occasionally for internal
 ;;; versions, especially for internal versions off the main CVS
 ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"1.0.6.29"
+"1.0.6.30"

Update of /cvsroot/sbcl/sbcl
In directory sc8-pr-cvs8.sourceforge.net:/tmp/cvs-serv19883

Modified Files:
	version.lisp-expr 
Log Message:
1.0.6.29: improved WITH-ARRAY-DATA on simple multi-dimensional arrays

	* Instead of looping to find the underlying one-dimensional simple
	  array, just return it directly.


Index: version.lisp-expr
===================================================================
RCS file: /cvsroot/sbcl/sbcl/version.lisp-expr,v
retrieving revision 1.3452
retrieving revision 1.3453
diff -u -d -r1.3452 -r1.3453
--- version.lisp-expr	5 Jun 2007 21:32:57 -0000	1.3452
+++ version.lisp-expr	6 Jun 2007 02:23:46 -0000	1.3453
@@ -17,4 +17,4 @@
 ;;; checkins which aren't released. (And occasionally for internal
 ;;; versions, especially for internal versions off the main CVS
 ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"1.0.6.28"
+"1.0.6.29"

Update of /cvsroot/sbcl/sbcl/src/compiler
In directory sc8-pr-cvs8.sourceforge.net:/tmp/cvs-serv19883/src/compiler

Modified Files:
	array-tran.lisp 
Log Message:
1.0.6.29: improved WITH-ARRAY-DATA on simple multi-dimensional arrays

	* Instead of looping to find the underlying one-dimensional simple
	  array, just return it directly.


Index: array-tran.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/compiler/array-tran.lisp,v
retrieving revision 1.76
retrieving revision 1.77
diff -u -d -r1.76 -r1.77
--- array-tran.lisp	7 May 2007 00:42:37 -0000	1.76
+++ array-tran.lisp	6 Jun 2007 02:23:46 -0000	1.77
@@ -666,10 +666,23 @@
                                 :node node
                                 :policy (> speed space))
   "inline non-SIMPLE-vector-handling logic"
-  (let ((element-type (upgraded-element-type-specifier-or-give-up array)))
-    `(%with-array-data-macro array start end
-                             :unsafe? ,(policy node (= safety 0))
-                             :element-type ,element-type)))
+  (let ((element-type (upgraded-element-type-specifier-or-give-up array))
+        (type (lvar-type array)))
+    (if (and (array-type-p type)
+             (listp (array-type-dimensions type))
+             (not (null (cdr (array-type-dimensions type)))))
+        ;; If it's a simple multidimensional array, then just return its
+        ;; data vector directly rather than going through
+        ;; %WITH-ARRAY-DATA-MACRO.  SBCL doesn't generally generate code
+        ;; that would use this currently, but we have encouraged users
+        ;; to use WITH-ARRAY-DATA and we may use it ourselves at some
+        ;; point in the future for optimized libraries or similar.
+        `(let ((data (truly-the (simple-array ,element-type (*))
+                                (%array-data-vector array))))
+           (values data 0 (length data) 0))
+        `(%with-array-data-macro array start end
+                                 :unsafe? ,(policy node (= safety 0))
+                                 :element-type ,element-type))))
 
 ;;;; array accessors