X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fseqtran.lisp;h=7a4e0fe7896e0a83cda70bca586a0e5d4a5bc65c;hb=b7192afcef9bbfd3fe1a4e2bfe3c73f853d164d1;hp=647a8626f8f1cace2baca91988c6cf640f22c09d;hpb=670010e3f3dcd62efaf23f61abdc73950edb88c6;p=sbcl.git

diff --git a/src/compiler/seqtran.lisp b/src/compiler/seqtran.lisp
index 647a862..7a4e0fe 100644
--- a/src/compiler/seqtran.lisp
+++ b/src/compiler/seqtran.lisp
@@ -44,13 +44,14 @@
 	     `(let ((,fn-sym ,fn)
 		    (,map-result (list nil)))
 		(do-anonymous ((,temp ,map-result) . ,(do-clauses))
-			      (,endtest (cdr ,map-result))
+			      (,endtest (truly-the list (cdr ,map-result)))
 		  (rplacd ,temp (setq ,temp (list ,call)))))))
 	  ((nil)
 	   `(let ((,fn-sym ,fn)
 		  (,n-first ,(first arglists)))
 	      (do-anonymous ,(do-clauses)
-			    (,endtest ,n-first) ,call))))))))
+			    (,endtest (truly-the list ,n-first))
+                            ,call))))))))
 
 (define-source-transform mapc (function list &rest more-lists)
   (mapfoo-transform function (cons list more-lists) nil t))
@@ -568,7 +569,7 @@
 				(specifier-type 'function)))
 		(when (policy *compiler-error-context*
 			      (> speed inhibit-warnings))
-		  (compiler-note
+		  (compiler-notify
 		   "~S may not be a function, so must coerce at run-time."
 		   n-fun))
 		(once-only ((n-fun `(if (functionp ,n-fun)
@@ -620,10 +621,10 @@
 ;;; Return a form that tests the free variables STRING1 and STRING2
 ;;; for the ordering relationship specified by LESSP and EQUALP. The
 ;;; start and end are also gotten from the environment. Both strings
-;;; must be SIMPLE-STRINGs.
+;;; must be SIMPLE-BASE-STRINGs.
 (macrolet ((def (name lessp equalp)
              `(deftransform ,name ((string1 string2 start1 end1 start2 end2)
-                                    (simple-string simple-string t t t t) *)
+                                    (simple-base-string simple-base-string t t t t) *)
                 `(let* ((end1 (if (not end1) (length string1) end1))
                         (end2 (if (not end2) (length string2) end2))
                         (index (sb!impl::%sp-string-compare
@@ -649,7 +650,7 @@
 
 (macrolet ((def (name result-fun)
              `(deftransform ,name ((string1 string2 start1 end1 start2 end2)
-                                   (simple-string simple-string t t t t) *)
+                                   (simple-base-string simple-base-string t t t t) *)
                 `(,',result-fun
                   (sb!impl::%sp-string-compare
                    string1 start1 (or end1 (length string1))
@@ -682,7 +683,7 @@
 
 (deftransform replace ((string1 string2 &key (start1 0) (start2 0)
 				end1 end2)
-		       (simple-string simple-string &rest t)
+		       (simple-base-string simple-base-string &rest t)
 		       *
 		       ;; FIXME: consider replacing this policy test
 		       ;; with some tests for the STARTx and ENDx
@@ -718,36 +719,38 @@
 ;;;
 ;;; FIXME: currently KLUDGEed because of bug 188
 (deftransform concatenate ((rtype &rest sequences)
-			   (t &rest simple-string)
-			   simple-string
+			   (t &rest (or simple-base-string
+					(simple-array nil (*))))
+			   simple-base-string
 			   :policy (< safety 3))
-  (collect ((lets)
-	    (forms)
-	    (all-lengths)
-	    (args))
-    (dolist (seq sequences)
-      (declare (ignorable seq))
-      (let ((n-seq (gensym))
-	    (n-length (gensym)))
-	(args n-seq)
-	(lets `(,n-length (the index (* (length ,n-seq) sb!vm:n-byte-bits))))
-	(all-lengths n-length)
-	(forms `(bit-bash-copy ,n-seq ,vector-data-bit-offset
-			       res start
-			       ,n-length))
-	(forms `(setq start (opaque-identity (+ start ,n-length))))))
-    `(lambda (rtype ,@(args))
-       (declare (ignore rtype))
-       ;; KLUDGE
-       (flet ((opaque-identity (x) x))
-	 (declare (notinline opaque-identity))
-	 (let* (,@(lets)
-		  (res (make-string (truncate (the index (+ ,@(all-lengths)))
-					      sb!vm:n-byte-bits)))
-		  (start ,vector-data-bit-offset))
-	   (declare (type index start ,@(all-lengths)))
-	   ,@(forms)
-	   res)))))
+  (loop for rest-seqs on sequences
+        for n-seq = (gensym "N-SEQ")
+        for n-length = (gensym "N-LENGTH")
+        for start = vector-data-bit-offset then next-start
+        for next-start = (gensym "NEXT-START")
+        collect n-seq into args
+        collect `(,n-length (* (length ,n-seq) sb!vm:n-byte-bits)) into lets
+        collect n-length into all-lengths
+        collect next-start into starts
+        collect `(if (and (typep ,n-seq '(simple-array nil (*)))
+		          (> ,n-length 0))
+		     (error 'nil-array-accessed-error)
+		     (bit-bash-copy ,n-seq ,vector-data-bit-offset
+		                    res ,start ,n-length))
+                into forms
+        collect `(setq ,next-start (+ ,start ,n-length)) into forms
+        finally
+        (return
+          `(lambda (rtype ,@args)
+             (declare (ignore rtype))
+             (let* (,@lets
+                      (res (make-string (truncate (the index (+ ,@all-lengths))
+                                                  sb!vm:n-byte-bits))))
+               (declare (type index ,@all-lengths))
+               (let (,@(mapcar (lambda (name) `(,name 0)) starts))
+                 (declare (type index ,@starts))
+                 ,@forms)
+               res)))))
 
 ;;;; CONS accessor DERIVE-TYPE optimizers